Chèn dòng vào giữa 2 dòng theo điều kiện

Liên hệ QC
T

Thiên Thanh1

Thành viên mới
Tham gia
16/10/20
Bài viết
36
Được thích
9
Anh chị và các bạn ơi, giúp em với
Em cảm ơn trước nhé!
 

File đính kèm

  • Chèn dòng vào giữa 2 dòng liền kề có số ký tự lớn hơn.xlsb
    9.7 KB · Đọc: 24
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Thiên Thanh1 đã viết:
Cảm ơn bạn
Tức là dòng nàođược chèn vào thìđiền câuđó vào bạn ơi.
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử xem nhé
PHP: 
Sub Insert_Row()
    Dim sRng As Range, Rng As Range
    Dim sArr(), dArr(1 To 65535, 1 To 1)
    Dim I As Long, K As Long, B As String
B = "B: Tr" & ChrW$(7843) & " l" & ChrW$(7901) & "i"
On Error GoTo Thoat
Set sRng = Application.InputBox(Prompt:="GPE ", Title:="Chon du lieu dau vao", Type:=8)
If sRng.Rows.Count * sRng.Columns.Count > 1 Then
    sArr = sRng.Value
    For I = 1 To UBound(sArr)
    
            If Len(sArr(I, 1)) <= 10 Then
                K = K + 1: dArr(K, 1) = sArr(I, 1)
                If Len(sArr(I + 1, 1)) > 10 Then
                    K = K + 1: dArr(K, 1) = sArr(I + 1, 1): I = I + 1
                End If
            Else
                K = K + 1: dArr(K, 1) = B
                K = K + 1:   dArr(K, 1) = sArr(I, 1)
            End If
     
    Next I
    If K Then
        Set Rng = Application.InputBox(Prompt:="GPE ", Title:="Chon o ghi du lieu", Type:=8)
        Rng.Resize(K, 1) = dArr
    End If
End If
Thoat:
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Bạn chạy thử xem nhé
PHP: 
Sub Insert_Row()
    Dim sRng As Range, Rng As Range
    Dim sArr(), dArr(1 To 65535, 1 To 1)
    Dim I As Long, K As Long, B As String
B = "B: Tr" & ChrW$(7843) & " l" & ChrW$(7901) & "i"
On Error GoTo Thoat
Set sRng = Application.InputBox(Prompt:="GPE ", Title:="Chon du lieu dau vao", Type:=8)
If sRng.Rows.Count * sRng.Columns.Count > 1 Then
    sArr = sRng.Value
    For I = 1 To UBound(sArr)
   
            If Len(sArr(I, 1)) <= 10 Then
                K = K + 1: dArr(K, 1) = sArr(I, 1)
                If Len(sArr(I + 1, 1)) > 10 Then
                    K = K + 1: dArr(K, 1) = sArr(I + 1, 1): I = I + 1
                End If
            Else
                K = K + 1: dArr(K, 1) = B
                K = K + 1:   dArr(K, 1) = sArr(I, 1)
            End If
    
    Next I
    If K Then
        Set Rng = Application.InputBox(Prompt:="GPE ", Title:="Chon o ghi du lieu", Type:=8)
        Rng.Resize(K, 1) = dArr
    End If
End If
Thoat:
End Sub
Nhấp chuột vào đây để mở rộng...
Chuẩn quá bạn ơi
Cảm ơn bạn rất nhiều
Chúc bạn cuối tuần vui vẻ.
 
Upvote 0
Bạn @PacificPR ơi chỉnh sử giúp mình với nhé
Mình chỉnh code của bạn như này nhưng nó không chạy
Chúc bạn ngày đầu tuần có nhiều thành công nhé. [CODE]Sub Insert_Row() Dim sRng As Range, Rng As Range Dim sArr(), dArr(1 To 65535, 1 To 1) Dim I As Long, K As Long, B As String B = "B: Tr" & ChrW$(7843) & " l" & ChrW$(7901) & "i" On Error GoTo Thoat 'Set sRng = Application.InputBox(Prompt:="GPE ", Title:="Chon du lieu dau vao", Type:=8) Set sRng = Range("B1:B2500") If sRng.Rows.Count * sRng.Columns.Count > 1 Then sArr = sRng.Value For I = 1 To UBound(sArr) If Len(sArr(I, 1)) <= 10 Then K = K + 1: dArr(K, 1) = sArr(I, 1) If Len(sArr(I + 1, 1)) > 10 Then K = K + 1: dArr(K, 1) = sArr(I + 1, 1): I = I + 1 End If Else K = K + 1: dArr(K, 1) = B K = K + 1: dArr(K, 1) = sArr(I, 1) End If Next I If K Then 'Set Rng = Application.InputBox(Prompt:="GPE ", Title:="Chon o ghi du lieu", Type:=8) Range("B65").Resize(K, 1) = dArr End If End If Thoat: End Sub [/CODE]
 

File đính kèm

  • Chèn dòng vào giữa 2 dòng liền kề có số ký tự lớn hơn.xlsb
    22.1 KB · Đọc: 5
Upvote 0
Thiên Thanh1 đã viết:
Bạn @PacificPR ơi chỉnh sử giúp mình với nhé
Mình chỉnh code của bạn như này nhưng nó không chạy
Chúc bạn ngày đầu tuần có nhiều thành công nhé. [CODE]Sub Insert_Row() Dim sRng As Range, Rng As Range Dim sArr(), dArr(1 To 65535, 1 To 1) Dim I As Long, K As Long, B As String B = "B: Tr" & ChrW$(7843) & " l" & ChrW$(7901) & "i" On Error GoTo Thoat 'Set sRng = Application.InputBox(Prompt:="GPE ", Title:="Chon du lieu dau vao", Type:=8) Set sRng = Range("B1:B2500") If sRng.Rows.Count * sRng.Columns.Count > 1 Then sArr = sRng.Value For I = 1 To UBound(sArr) If Len(sArr(I, 1)) <= 10 Then K = K + 1: dArr(K, 1) = sArr(I, 1) If Len(sArr(I + 1, 1)) > 10 Then K = K + 1: dArr(K, 1) = sArr(I + 1, 1): I = I + 1 End If Else K = K + 1: dArr(K, 1) = B K = K + 1: dArr(K, 1) = sArr(I, 1) End If Next I If K Then 'Set Rng = Application.InputBox(Prompt:="GPE ", Title:="Chon o ghi du lieu", Type:=8) Range("B65").Resize(K, 1) = dArr End If End If Thoat: End Sub [/CODE]
Nhấp chuột vào đây để mở rộng...
Bạn xem thử nhé
PHP: 
Sub Insert_Row()
    Dim sArr(), dArr(1 To 65535, 1 To 1)
    Dim I As Long, K As Long, B As String
B = "B: Tr" & ChrW$(7843) & " l" & ChrW$(7901) & "i"
sArr = Range("B1", Range("B1").End(xlDown)).Value
For I = 1 To UBound(sArr)
    If Len(sArr(I, 1)) <= 10 Then
        K = K + 1: dArr(K, 1) = sArr(I, 1)
        If Len(sArr(I + 1, 1)) > 10 Then
            K = K + 1: dArr(K, 1) = sArr(I + 1, 1): I = I + 1
        End If
    Else
        K = K + 1: dArr(K, 1) = B
        K = K + 1:   dArr(K, 1) = sArr(I, 1)
    End If
Next I
If K Then
    Range("B65", Range("B65").End(xlDown)).ClearContents
    Range("B65").Resize(K, 1) = dArr
End If
End Sub
 
Upvote 0
PacificPR đã viết:
Bạn xem thử nhé
PHP: 
Sub Insert_Row()
    Dim sArr(), dArr(1 To 65535, 1 To 1)
    Dim I As Long, K As Long, B As String
B = "B: Tr" & ChrW$(7843) & " l" & ChrW$(7901) & "i"
sArr = Range("B1", Range("B1").End(xlDown)).Value
For I = 1 To UBound(sArr)
    If Len(sArr(I, 1)) <= 10 Then
        K = K + 1: dArr(K, 1) = sArr(I, 1)
        If Len(sArr(I + 1, 1)) > 10 Then
            K = K + 1: dArr(K, 1) = sArr(I + 1, 1): I = I + 1
        End If
    Else
        K = K + 1: dArr(K, 1) = B
        K = K + 1:   dArr(K, 1) = sArr(I, 1)
    End If
Next I
If K Then
    Range("B65", Range("B65").End(xlDown)).ClearContents
    Range("B65").Resize(K, 1) = dArr
End If
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn @PacificPR chuẩn rồi bạn ơi
Cảm ơn bạn rất nhiều nhé.
Chúc bạn vạn sự thành công
 
Upvote 0
Bạn @PacificPR kiểm tra lại giúp mình với
Mình thấy nó vẫn sai sai bạn ơi
 

File đính kèm

  • Chèn dòng vào giữa 2 dòng liền kề có số ký tự lớn hơn.xlsb
    22.1 KB · Đọc: 3
Upvote 0

File đính kèm

  • Chèn dòng vào giữa 2 dòng liền kề có số ký tự lớn hơn (2).xlsb
    22.1 KB · Đọc: 4
Upvote 0
PacificPR đã viết:
Sao trong file của bạn cái If Len(sArr(I + 1, 1)) > 10 Then nó lại thành If Len(sArr(I + 1, 1)) > 20 Then rồi
Nhấp chuột vào đây để mở rộng...
Bởi vì mình cho nó điều kiện có nhiều hơn 20 ký tự mà
Nếu cho điều kiện khác thì code bị sai bạn à
Bạn nghiên cứu giúp mình "Khi sửa cho các điều kiện khác thì code vẫn đúng với nhé"
Cảm ơn bạn!
 
Upvote 0
Thiên Thanh1 đã viết:
Bởi vì mình cho nó điều kiện có nhiều hơn 20 ký tự mà
Nếu cho điều kiện khác thì code bị sai bạn à
Bạn nghiên cứu giúp mình "Khi sửa cho các điều kiện khác thì code vẫn đúng với nhé"
Cảm ơn bạn!
Nhấp chuột vào đây để mở rộng...
Mình đang chốt với nhau là ở chỗ 10 ký tự mà
 
Upvote 0
Thiên Thanh1 đã viết:
Anh chị và các bạn ơi, giúp em với
Em cảm ơn trước nhé!
Nhấp chuột vào đây để mở rộng...
Thử xem nào bác.
Cột D không có ô trống nhé.
Mã: 
Sub Macro3()
Dim i As String
i = InputBox("Search", "Thông báo")
     Columns("D:D").Select
    Selection.Replace What:=i, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = i
    Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("D:D").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "OK______"
End Sub
 
Upvote 0
hungtin1997 đã viết:
Thử xem nào bác.
Cột D không có ô trống nhé.
Mã: 
Sub Macro3()
Dim i As String
i = InputBox("Search", "Thông báo")
     Columns("D:D").Select
    Selection.Replace What:=i, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = i
    Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("D:D").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "OK______"
End Sub
Nhấp chuột vào đây để mở rộng...
Hai Bạn này vào diễn đàn cùng ngày ( 16 Tháng mười 2020 ) nè :p:p:p
 
Upvote 0
hungtin1997 đã viết:
Thử xem nào bác.
Cột D không có ô trống nhé.
Mã: 
Sub Macro3()
Dim i As String
i = InputBox("Search", "Thông báo")
     Columns("D:D").Select
    Selection.Replace What:=i, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = i
    Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("D:D").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "OK______"
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi, bạn đưa code vào file và chọn vùng chính xác giúp mình với nhé.
 
Upvote 0
Upvote 0
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
Trả lời
4
Đọc
42
cantl
C
ann266
Kế toán kho F&B
    • Cười
2
Trả lời
21
Đọc
206
ann266
ann266
P
Hướng dẫn giải bài tập excel
Trả lời
2
Đọc
62
VetMini
V
T
Cần bạn viết phần mềm quản lý quán karaoke bằng excel
Trả lời
7
Đọc
160
VetMini
V
senna
  • Question
Xin giúp đỡ tổng hợp dữ liệu từ nhiều file vào 1 file mà không cần mở file
Trả lời
1
Đọc
66
tle2003
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom