VBA для добавления значений ячеек при совпадении двух ячеек

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, помещаются в ваш выходной диапазон.