تعديل كود الاستاذ سليم الدالة VlookUp

Sub Other_macro()

Dim R%, RoA, i%

Dim F_rg As Range, Rg As Range

Dim S1 As Worksheet, S2 As Worksheet

Dim t

t = Timer

    With Application

      .ScreenUpdating = False

      .Calculation = xlCalculationManual

    End With

Set S1 = Sheets("Sheet1"): Set S2 = Sheets("Sheet2")

i = 2

With S2

.Range("C2", Range("E1").End(4)).ClearContents

 Do Until .Cells(i, 1) = vbNullString

   Set F_rg = S1.Range("C:C").Find(.Cells(i, 1), lookat:=1)

    If F_rg Is Nothing Then GoTo Next_i

    R = F_rg.Row

    With .Cells(i, 1)

      .Offset(, 2) = S1.Cells(R, "A")

      .Offset(, 3) = S1.Cells(R, "B")

      .Offset(, 4) = S1.Cells(R, "D")

    End With

Next_i:

    i = i + 1

   Loop



End With

   With Application

      .ScreenUpdating = True

      .Calculation = xlCalculationAutomatic

    End With

    MsgBox "This Operation takes:" & Chr(10) & _

    (Timer - t) * 1000 & " Milli_Seconde"

End Sub

Sub Test()

    Dim a, x, ws As Worksheet, sh As Worksheet, i As Long

    Application.ScreenUpdating = False

        Set ws = ThisWorkbook.Worksheets("Sheet1")

        Set sh = ThisWorkbook.Worksheets("Sheet2")

        a = sh.Range("A2:A" & sh.Cells(Rows.Count, 1).End(xlUp).Row).Value

        ReDim b(1 To UBound(a, 1), 1 To 3)

        For i = LBound(a) To UBound(a)

            x = Application.Match(a(i, 1), ws.Columns(3), 0)

            If Not IsError(x) Then

               b(i, 1) = ws.Cells(x, 1).Value

               b(i, 2) = ws.Cells(x, 2).Value

               b(i, 3) = ws.Cells(x, 4).Value

            Else

                b(i, 1) = Empty: b(i, 2) = Empty: b(i, 3) = Empty

            End If

        Next i

        sh.Range("C2:E" & Rows.Count).ClearContents

        sh.Range("C2").Resize(UBound(b, 1), UBound(b, 2)).Value = b

    Application.ScreenUpdating = True

End Sub