How to loop if multiple of the same data are matched? - arrays

Question

I'm trying to create a loop on the below code so if there are multiple matches of Column A to Column B it continue to fill out column B with the data from column A.
I've been suggested to create variant arrays and loop arrays, but I'm not that advanced yet after looking into it. Thanks.
Sub Test_match_fill_data()
Dim aCell
Dim e, k As Long, matchrow As Long
Dim w1, w2 As Worksheet
Dim cell As Range
Set w1 = Workbooks("Book1").Sheets("Sheet1")
Set w2 = Workbooks("Book2").Sheets("Sheet2")
e = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
k = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row
For Each aCell In w1.Range("A2:A" & e)
On Error Resume Next
matchrow = w2.Columns("A:A").Find(What:=Left$(aCell.Value, 6) & "*", LookAt:=xlWhole).Row
On Error GoTo 0
If matchrow = 0 Then
Else
w2.Range("B" & matchrow).Value = aCell.Offset(0, 1).Value
End If
matchrow = 0
Next
End Sub

Answer 1

Your code would work if you searched Book1 for values from Book2. Here is an array version.
Option Explicit
Sub Test_match_fill_data()
Dim w1 As Worksheet, w2 As Worksheet
Dim ar1, ar2, matchrow, n As Long
Dim lastRow As Long, i As Long, s As String
Set w1 = Workbooks("Book1").Sheets("Sheet1")
With w1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ar1 = .Range("A2:B" & lastRow).Value2
End With
Set w2 = Workbooks("Book2").Sheets("Sheet2")
With w2
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ar2 = .Range("A2:B" & lastRow).Value2
End With
For i = 1 To UBound(ar2)
s = Left(ar2(i, 1), 6)
If Len(s) > 0 Then
matchrow = Application.Match(s & "*", Application.Index(ar1, 0, 1), 0)
'Debug.Print i, s, matchrow
If Not IsError(matchrow) Then
ar2(i, 2) = ar1(matchrow, 2)
n = n + 1
End If
End If
Next
' copy array back to sheet
w2.Range("A2:B" & UBound(ar2) + 1) = ar2
MsgBox n & " rows updated"
End Sub

Answer 2

You can use the INDEX/MATCH formula - and then replace the results by values - no need for an array etc.
I put my assumptions in the code
Sub insertConsultants()
Dim wb1 As Workbook
Set wb1 = Workbooks("wb1.xlsx")
Dim rgDataSource As Range
'Assumption: Make = column A - first value in A3
'maybe you have to adjust this to your needs
'CurrentRegion: no empty rows within in data area
Set rgDataSource = wb1.Worksheets(1).Range("A3").CurrentRegion
Dim wb2 As Workbook: Set wb2 = Workbooks("wb2.xlsx")
Dim rgTarget As Range
'Assumption: Make = column A - first value in A3
'maybe you have to adjust this to your needs
Set rgTarget = wb2.Sheets(1).Range("A3").CurrentRegion
With rgTarget .Offset(, 1).Resize(, 1)
' = consultants column
.Formula = "=INDEX(" & rgDataSource.Columns(2).Address(True, True, , True) & ",MATCH(A3," & rgDataSource.Columns(1).Address(True, True, , True) & ",0))"
.Value = .Value
End With
End Sub
IMPORTANT: you always have to define each variable indivdually:
With your code Dim w1, w2 As Worksheet w1 is a variant not a worksheet. This could lead to errors.