Snasui Excel Forum

Code: Select all

Sub test()
Dim rall As Range, r As Range
    Dim dataAll As Range
    Dim l As Long, allRows As Long
    Application.ScreenUpdating = False
    With Worksheets("sheet1")
        If .Range("B2").Value <= "0" Then 'End
         MsgBox "äÁèÁÕ ID ¹Õéã¹Ãкº", vbCritical
           Exit Sub
           End If
        Set rall = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
    End With
    
    Set wb = Workbooks.Open("C:\Users\IT\Desktop\New folder\db.xlsx", False, False)
    With wb.Sheets("sheet1")
        Set dataAll = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
        allRows = dataAll.Rows.Count
    End With
    
    For Each r In rall
        For l = allRows To 1 Step -1
            If dataAll(l).Value = r.Value Then
                r.Resize(1, 3).Copy
                dataAll(l).Resize(1, 3).Font.Color = -4165632
                dataAll(l).Resize(1, 3).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                Application.ScreenUpdating = True
                Exit For
            End If
        Next l
    Next r
    wb.Close True
    Worksheets("sheet1").Range("A2:A10,C2:C10").ClearContents
    Range("A2").Activate
End Sub

Code: Select all

If dataAll(l).Value = r.Value Then
    r.Offset(0, 2).Copy
    dataAll(l).Resize(1, 3).Font.Color = -4165632
    dataAll(l).Offset(0, 2).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit For
End If

Code: Select all

r.Offset(1, 3).Copy
                dataAll(l).Resize(1, 9).Font.Color = -4165632
                dataAll(l).Offset(1, 3).PasteSpecial xlPasteValues