Nhờ viết code VBA - Dò tìm và chèn dòng (1 người xem)

[thanhduc_iit]

Chào mọi người,
Do em không có khả năng viết code VBA nên nhờ mọi người viết dùm em đoạn code VBA thực hiện yêu cầu Dò tìm và chèn dòng kết quả.
Chi tiết yêu cầu em miêu tả trong file đính kèm.
Rất mong mọi người nhiệt tình giúp đỡ, em cảm ơn nhiều ạ!

 

[killitmore]

Bạn copy bảng nguồn sang ô A1 của 1 sheet mới rồi chạy code này là được

Option ExplicitSub chen_dong()
Dim lrow, n As Long
Dim i As Integer
    Sheet2.Select
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A3", "A" & lrow).Copy Destination:=[j1]
    Range("$J$1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
    [j1].CurrentRegion.Offset(0, 1).Value = 0
    [j1].CurrentRegion.Copy Destination:=Cells(lrow + 1, 1)
    [j1].CurrentRegion.Clear
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A3", "A" & lrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("B3", "B" & lrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A3", "B" & lrow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    For i = 3 To lrow
        If Cells(i, 2).Value = 0 Then
            Cells(i, 2).ClearContents
        End If
    Next i
    
End Sub

 

[thanhduc_iit]

Bạn copy bảng nguồn sang ô A1 của 1 sheet mới rồi chạy code này là được

Option ExplicitSub chen_dong()
Dim lrow, n As Long
Dim i As Integer
    Sheet2.Select
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A3", "A" & lrow).Copy Destination:=[j1]
    Range("$J$1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
    [j1].CurrentRegion.Offset(0, 1).Value = 0
    [j1].CurrentRegion.Copy Destination:=Cells(lrow + 1, 1)
    [j1].CurrentRegion.Clear
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A3", "A" & lrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("B3", "B" & lrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A3", "B" & lrow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    For i = 3 To lrow
        If Cells(i, 2).Value = 0 Then
            Cells(i, 2).ClearContents
        End If
    Next i
    
End Sub

Rất cảm ơn bác đã giúp đỡ, nhưng kết quả chỉ gần đúng yêu cầu bác ạ.
Em gửi lại file excel mong bác chỉnh lại giúp em

 

[thanhduc_iit]

Option Explicit
Public Sub GPE()
Dim Arr, sArr, dArr, I As Long, J As Long, K As Long
With Sheet1
    Arr = .Range("A3", .Range("B3").End(4)).Value
End With
With Sheet2
    sArr = .Range("A3", .Range("A3").End(4)).Value
End With
ReDim dArr(1 To UBound(Arr) * UBound(sArr), 1 To 2)
For I = 1 To UBound(sArr)
    K = K + 1
    dArr(K, 1) = sArr(I, 1)
    For J = 1 To UBound(Arr)
        If sArr(I, 1) = Arr(J, 1) Then
            K = K + 1
            dArr(K, 1) = Arr(J, 1)
            dArr(K, 2) = Arr(J, 2)
        End If
    Next J
Next I
With Sheet3
    .Range("A3").Resize(K, 2).Value = dArr
End With
End Sub

Cảm ơn bác rất nhiều!
Em sẽ cố gắng xem code của bác để hiểu thêm
Nếu được thì mong bác thêm ghi chú vào code ạ!

 

[killitmore]

Option Explicit
Public Sub GPE()
Dim Arr, sArr, dArr, I As Long, J As Long, K As Long
With Sheet1
    Arr = .Range("A3", .Range("B3").End(4)).Value
End With
With Sheet2
    sArr = .Range("A3", .Range("A3").End(4)).Value
End With
ReDim dArr(1 To UBound(Arr) * UBound(sArr), 1 To 2)
For I = 1 To UBound(sArr)
    K = K + 1
    dArr(K, 1) = sArr(I, 1)
    For J = 1 To UBound(Arr)
        If sArr(I, 1) = Arr(J, 1) Then
            K = K + 1
            dArr(K, 1) = Arr(J, 1)
            dArr(K, 2) = Arr(J, 2)
        End If
    Next J
Next I
With Sheet3
    .Range("A3").Resize(K, 2).Value = dArr
End With
End Sub

Em chạy code của Bác mà ko dk T.T bác xem lại code hộ em với

 

[killitmore]

THank bác em xem dk roài bác hpkhuong đúng là chuyên gia xài Array, hem mộ

 

[SA_DQ]

Bạn xem file này & chúc vui!

 

[thanhduc_iit]

Bạn xem file này & chúc vui!

Nếu bảng đích trùng lại giá trị thì code của bác chạy vẫn ra, nhưng phát sinh lỗi trình bày bác ạ