Option Explicit
Sub lookupData()
' Constants
Const srcName As String = "Sheet1"
Const srcFirstCell As String = "M2"
Const tgtName As String = "Sheet1"
Const tgtFirstCell As String = "C2"
Const NumOfDataCols As Long = 5
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Write values from ranges to arrays.
Dim ws As Worksheet
Dim First As Range
Dim Last As Range
Dim rng As Range
' Define Lookup Column Range ('rng') of Source Range.
Set ws = wb.Worksheets(srcName)
Set First = ws.Range(srcFirstCell)
Set Last = ws.Cells(ws.Rows.Count, First.Column).End(xlUp)
Set rng = ws.Range(First, Last)
' Write values from Lookup Column of Source Range
' to Source Lookup Array ('Lookup').
Dim Lookup As Variant
Lookup = rng.Value
' Write values from Data Columns of Source Range
' to Source Data Array ('Data').
Dim Data As Variant
Data = rng.Offset(, 1).Resize(, NumOfDataCols).Value
' Define Lookup Column Range ('rng') of Target Range.
Set ws = wb.Worksheets(tgtName)
Set First = ws.Range(tgtFirstCell)
Set Last = ws.Cells(ws.Rows.Count, First.Column).End(xlUp)
Set rng = ws.Range(First, Last)
' Write values from Lookup column of Target Range
' to Target Array ('Target').
Dim Target As Variant
Target = rng.Value
ReDim Preserve Target(1 To UBound(Target, 1), 1 To NumOfDataCols)
' Write values from Source Array to Target Array.
Dim CurrentValue As Variant
Dim CurrentIndex As Variant
Dim i As Long
Dim j As Long
For i = 1 To UBound(Target, 1)
CurrentValue = Target(i, 1)
CurrentIndex = Application.Match(CurrentValue, Lookup, 0)
If Not IsError(CurrentIndex) Then
For j = 1 To NumOfDataCols
Target(i, j) = Data(CurrentIndex, j)
Next j
Else
Target(i, 1) = Empty
End If
Next i
' Write values from Target Array to Target Range ('rng').
Set rng = rng.Resize.Offset(, 1).Resize(, NumOfDataCols)
rng.Value = Target
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub