如果匹配多个相同数据，如何循环？

Question

我试图在下面的代码中创建一个循环，这样如果 A 列与 B 列有多个匹配项，它会继续用 A 列中的数据填充 B 列。

有人建议我创建变体数组和循环数组，但在研究之后我还没有那么高级。谢谢

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

如果您在 Book1 中搜索 Book2 中的值，您的代码将有效。这是数组版本。

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

您可以使用 INDEX/MATCH 公式 - 然后用值替换结果 - 不需要数组等。

我把我的假设写进了代码


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

重要：你总是必须单独定义每个变量：

使用您的代码 Dim w1, w2 As Worksheet w1 是变体而不是工作表。这可能会导致错误。

如果匹配多个相同数据，如何循环？

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

arrays

excel

vba

loops

variant