Sub copyData()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim r1 As Range, r2 As Range
Dim lRow As Long
Dim title As String
Set wb1 = Workbooks("workbook1.xlsx") 'source workbook
Set ws1 = wb1.Sheets("Sheet1")
Set wb2 = Workbooks("workbook2.xlsx") 'destination workbook
Set ws2 = wb2.Sheets("Sheet1")
row = 2
Do While ws1.Range("A" & row).Value <> ""
col = 2
Do While ws1.Range(Cells(1, col).Address).Value <> ""
Set rng1 = ws1.Range("A" & row)
Set rng2 = ws1.Range(Cells(1, col).Address)
Set rng3 = ws2.Range("A:A").Find(rng2.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not rng3 Is Nothing Then
Set rng4 = ws2.Range("1:1").Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not rng4 Is Nothing Then
ws2.Cells(rng3.row, rng4.Column).Value = ws1.Cells(rng1.row, rng2.Column).Value
End If
End If
col = col + 1
Loop
row = row + 1
Loop
End Sub