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

【问题标题】：How to loop if multiple of the same data are matched?如果匹配多个相同的数据，如何循环？
【发布时间】：2021-12-23 00:55:02
【问题描述】：

我正在尝试在下面的代码上创建一个循环，因此如果 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

【问题讨论】：

sheet1 的 A 列中的值是否唯一？
旁注：您可以使用Range 变量来简化事情，而不是使用错误处理和混乱的逻辑来确定是否找到匹配项。 Range.Find 如果未找到，则返回 Nothing。您可以将结果保存为Range，然后测试是否为Not matchrange Is Nothing。
@CDP1802 - 我在上面的 Book1 和 2 上添加了一些图片。我现在所拥有的工作，如果有多个匹配项，则不会添加到 Book2 的顾问列。
你能添加一张所需输出的图片吗？
Book2 Consultant 列是必需的输出.. 从空白开始，然后在宏运行后，它会填充顾问列

标签： arrays excel vba loops variant

【解决方案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

【讨论】：

谢谢。这是一个很大的帮助。

【解决方案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 是一个变体而不是工作表。这可能会导致错误。

【讨论】：