Sub CopyTableData()
Dim wshSrc As Worksheet
Dim wshDest As Worksheet
Set wshSrc = ActiveWorkbook.Worksheets(1)
Set wshDest = ActiveWorkbook.Worksheets(2)
Dim rng As Range
Dim iFound As Integer
Dim rngFounds() As Range
Dim strSearch As String
For Each rng In wshDest.UsedRange.Rows
If rng.Cells(1, 1).Value <> strSearch Then
strSearch = rng.Cells(1, 1).Value
SearchValues wshSrc, rngFounds, strSearch
iFound = 0
Do While rng.Offset(iFound).Cells(1, 1).Value = strSearch
If Not rngFounds(iFound) Is Nothing Then
rng.Offset(iFound).Cells(1, 2).Formula = rngFounds(iFound).Cells(1, 2).Value
End If
iFound = iFound + 1
Loop
End If
Next
End Sub
Sub SearchValues(wsh As Worksheet, ByRef rngFounds() As Range, ByVal strSearch As String)
Dim rng As Range
Dim iFound As Integer
ReDim rngFounds(0)
For Each rng In wsh.UsedRange.Rows
If rng.Cells(1, 1).Value = strSearch Then
ReDim Preserve rngFounds(iFound)
Set rngFounds(iFound) = rng
iFound = iFound + 1
End If
Next
End Sub