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

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

CodePudding user response：

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

CodePudding user response：

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.