Chèn dòng theo điều kiện (1 người xem)

[HocVBAExcel]

Nếu dữ liệu cột A giống nhau thì chèn thêm dòng .
Kết quả mình để trong file đình kèm.

 

[giangleloi]

Nếu dữ liệu cột A giống nhau thì chèn thêm dòng .
Kết quả mình để trong file đình kèm.

Chạy code sau. Tôi không làm bảng 2. Từ bảng 1 ra luôn bảng kết quả:

Sub GLL()
Dim Arr(), vlArr(1 To 10000, 1 To 4), I, J, K, Dic, Tem
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
Arr = .Range(.[A2], .[D65000].End(3)).Value
For I = 1 To UBound(Arr, 1)
  Tem = Arr(I, 1)
   If Not Dic.exists(Tem) Then
        K = K + 1
        Dic.Add Tem, K
        vlArr(K, 1) = Arr(I, 1)
          For J = 2 To 4
            vlArr(K + 1, J) = Arr(I, J)
          Next
          K = K + 1
     Else
          K = K + 1
         For J = 2 To 4
            vlArr(K, J) = Arr(I, J)
         Next
   End If
Next
.[K2:N10000].ClearContents
.[K2].Resize(K, 4) = vlArr
End With
Set Dic = Nothing
End Sub

P/s: Dữ liệu kiểu khác sai ráng chịu.

 

[SA_DQ]

Một cách khác xíu để bạn tham khảo; Những mong nó dễ hiểu hơn chút đĩnh nào đó:

Option Explicit
Sub GPE_ThemDong()
 Dim Arr(), Dict As Object
 Dim J As Long, W As Long, Col As Byte
 Dim Tmp As String
 Set Dict = CreateObject("Scripting.Dictionary")
 With Sheets("Data")
    Arr = .Range(.[A2], .[D65000].End(3)).Value
    ReDim dArr(1 To 2 * UBound(Arr()), 1 To 4)
    For J = 1 To UBound(Arr())
        Tmp = Arr(J, 1)
        If Not Dict.Exists(Tmp) Then
            W = W + 1:              Dict.Add Tmp, W
            dArr(W, 1) = Tmp:       W = W + 1
            For Col = 2 To 4
                dArr(W, Col) = Arr(J, Col)
            Next Col
        Else
            W = W + 1
            For Col = 2 To 4
                dArr(W, Col) = Arr(J, Col)
            Next Col
        End If
    Next J
 End With
 [F2].Resize(W, 4).Value = dArr()
End Sub

 

[doveandrose]

sáng sớm giải trí tí coi . hi hi

Public Sub hello()
Dim arr, dArr, r As Long, k As Long, tmp
With Sheets("Data")
    arr = .Range("A2:D" & .[A65000].End(xlUp).Row).Value
    ReDim dArr(1 To 2 * UBound(arr), 1 To 4)
    For r = 1 To UBound(arr) Step 1
        If arr(r, 1) <> tmp Then
            k = k + 1
            dArr(k, 1) = arr(r, 1)
            tmp = arr(r, 1)
        End If
        k = k + 1
        dArr(k, 2) = arr(r, 2)
        dArr(k, 3) = arr(r, 3)
        dArr(k, 4) = arr(r, 4)
    Next
    .Range("K2:N20000").Clear
    .Range("K2").Resize(k, 4).Value = dArr
    .Range("K2").Resize(k, 4).Borders.LineStyle = xlContinuous
    'For r = 1 To k Step 1
        'If dArr(r, 2) = Empty Then .Range("K" & r + 1).Font.ColorIndex = 3
    'Next
End With
End Sub

 

[HocVBAExcel]

Chạy code sau. Tôi không làm bảng 2. Từ bảng 1 ra luôn bảng kết quả:

Sub GLL()
Dim Arr(), vlArr(1 To 10000, 1 To 4), I, J, K, Dic, Tem
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
Arr = .Range(.[A2], .[D65000].End(3)).Value
For I = 1 To UBound(Arr, 1)
  Tem = Arr(I, 1)
   If Not Dic.exists(Tem) Then
        K = K + 1
        Dic.Add Tem, K
        vlArr(K, 1) = Arr(I, 1)
          For J = 2 To 4
            vlArr(K + 1, J) = Arr(I, J)
          Next
          K = K + 1
     Else
          K = K + 1
         For J = 2 To 4
            vlArr(K, J) = Arr(I, J)
         Next
   End If
Next
.[K2:N10000].ClearContents
.[K2].Resize(K, 4) = vlArr
End With
Set Dic = Nothing
End Sub

P/s: Dữ liệu kiểu khác sai ráng chịu.

Cám ơn anh rất nhiều