Question

我有以下代码在工作表1的C列和工作表2的E列之间寻找匹配项，当存在匹配项时，它将复制同一行中某些其他单元格中的值。它的工作原理很好，但是当工作表1的C列和工作表2的E列之间存在多个匹配项时，每个后续匹配项都将覆盖原始匹配项。

我该如何编码，以便第一个匹配项将复制值，但随后的任何匹配项将仅添加其值，而不是覆盖它们？

提前谢谢！

 Sub OnClick()
 'Define your variables
Dim ws1 As Worksheet, ws2 As Worksheet, cel As Range, i As Long

'Assign your worksheet variables
Set ws1 = ThisWorkbook.Sheets("PLANNER_ONGOING_DISPLAY_SHEET")
Set ws2 = ThisWorkbook.Sheets("REPORT_DOWNLOAD")

    'First loop through each cell in Sheet2, column E, start at row 2 to account
    'for header row) to get the value to find in sheet1, column C.
    For Each cel In ws2.Range("E2:E" & ws2.Range("E" & ws2.Rows.Count).End(xlUp).Row)

        'Then loop through each cell in Sheet1, Column C. If you get a match, then
        'copy the value from Sheet2, Column B, cel.row to Sheet1, Column S, i row.
        For i = 2 To ws1.Range("L" & ws1.Rows.Count).End(xlUp).Row

            If cel.Value = ws1.Cells(i, 3).Value Then
                ws1.Cells(i, 3).Offset(, 16).Value = cel.Offset(, 3).Value
                ws1.Cells(i, 3).Offset(, 15).Value = cel.Offset(, 4).Value
                ws1.Cells(i, 3).Offset(, 17).Value = cel.Offset(, 7).Value
            End If

        Next i 'loops through every used cell in Column C for all matches
    Next cel 'loop to the next cell in Sheets2, Columns E

End Sub

Answer 1

根据您在评论中的要求，这是一种更有效的版本，可以满足您的要求：

Sub OnClick()

Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("PLANNER_ONGOING_DISPLAY_SHEET")
Set ws2 = ThisWorkbook.Sheets("REPORT_DOWNLOAD")

Dim arr_1 As Variant, arr_2 As Variant, arr_result As Variant
arr_1 = ws1.Range("C2:C" & ws2.Range("L" & ws2.Rows.Count).End(xlUp).Row).Value2
arr_2 = ws2.Range("E2:L" & ws2.Range("E" & ws2.Rows.Count).End(xlUp).Row).Value2

ReDim arr_result(LBound(arr_2) To UBound(arr_2), 1 To 3)

Dim i As Long, j As Long

For i = LBound(arr_1, 1) To UBound(arr_1, 1)
    For j = LBound(arr_2, 1) To UBound(arr_2, 1)

        If arr_1(i, 1) = arr_2(j, 1) Then
            'use this if you're handling numbers
            arr_result(i, 1) = arr_result(i, 1) + arr_2(j, 5)
            arr_result(i, 2) = arr_result(i, 2) + arr_2(j, 4)
            arr_result(i, 3) = arr_result(i, 3) + arr_2(j, 8)

            'use this if you're handling strings
            arr_result(i, 1) = arr_result(i, 1) & arr_2(j, 5)
            arr_result(i, 2) = arr_result(i, 2) & arr_2(j, 4)
            arr_result(i, 3) = arr_result(i, 3) & arr_2(j, 8)
        End If

    Next j
Next i

ws1.Cells(2, 18).Resize(UBound(arr_result, 1), 3).Value2 = arr_result

End Sub

此过程将所有相关数据放入数组并将所需结果写入arr_result。然后，将arr_result中存储的所有值放入输出范围。

VBA在两个单元格之间的匹配项上添加单元格值

1 个答案: