Блог

У меня есть Source лист (в котором данные представлены в 7 столбцах, а основной столбец, который нужно сопоставить, — это столбец A), а на втором листе Target мне нужно разобраться с столбцом C для поиска существующих элементов и отображения результатов в соответствии с вхождениями. Я привел простой пример, чтобы объяснить проблему и улучшить представление ожидаемого результата, это Source лист

 Header1 Header2 Header3 Header4 Header5 Header6 Header7
101     H2_1    H3_1    H4_1    H5_1    H6_1    H7_1
102     H2_2    H3_2    H4_2    H5_2    H6_2    H7_2
103     H2_3    H3_3    H4_3    H5_3    H6_3    H7_3
102     H2_4    H3_4    H4_4    H5_4    H6_4    H7_4
101     H2_5    H3_5    H4_5    H5_5    H6_5    H7_5
103     H2_6    H3_6    H4_6    H5_6    H6_6    H7_6
105     H2_7    H3_7    H4_7    H5_7    H6_7    H7_7
104     H2_8    H3_8    H4_8    H5_8    H6_8    H7_8
  

И это ожидаемый результат

Друг мог бы помочь мне с формулой, но мне нужно использовать код VBA (предпочитая массивы)

 =IFERROR(INDEX(Source!$B$2:$G$9,AGGREGATE(15,6,ROW($C$3:$C$11)-2/($C3=Source!$A$2:$A$9),MOD((ROW($A1)-1),COUNTIF($C$3:$C$11,$C3)) 1),MATCH(Target!D$2,Source!$B$1:$G$1,0)),"")
  

Попробуйте следующий код, пожалуйста. Предполагается, что на листе «Источник» (с именем «Источник») данные обрабатываются в диапазоне A2: G — последняя строка в столбце A: A, а на листе «Цель» хранится диапазон, подлежащий обработке, в диапазоне C3: C — последняя строка в столбце C: C:

 Sub testMatchEntries()
 Dim shS As Worksheet, shT As Worksheet, lastRS As Long, lastRT As Long
 Dim dict As New Scripting.Dictionary, arrS As Variant, arrT As Variant, arrInt As Variant
 Dim i As Long, j As Long, arrExcl As Variant, k As Long, El As Variant, boolFound As Boolean
 Dim iRow As Long, R As Long, arrHeaders As Variant
 
 Set shS = Worksheets("Source") 'use here your sheet, please
 Set shT = Worksheets("Target") 'use here your sheet, please
 lastRS = shS.Range("A" amp; rows.count).End(xlUp).row
 lastRT = shT.Range("C" amp; rows.count).End(xlUp).row
 shT.Range("D3:H" amp; lastRT).ClearContents 'clear the previous run filled cells
 arrS = shS.Range("A2:G" amp; lastRS).value  'put the necessary range in an array
 arrT = shT.Range("C3:F" amp; lastRT).value  'put the necessary range in an array
 'Collect the headers to be passed in the Source worksheet
 arrHeaders = Array(shS.Range("C1").value, shS.Range("D1").value, shS.Range("G1").value)
 
 ReDim arrExcl(UBound(arrT) - 1) 'create an array to exclude the already used elements
 For i = 1 To UBound(arrT)
    For Each El In arrExcl
        If El = arrT(i, 1) Then GoTo OverProcessing 'exclude the processed element for the next iteration
    Next
    For j = 1 To UBound(arrS)
        If arrT(i, 1) = arrS(j, 1) Then
            boolFound = True 'a match has been found
            If Not dict.Exists(arrT(i, 1)) Then 'fill data in a dictionary if not already esists
                dict.Add arrT(i, 1), arrS(j, 3) amp; ":" amp; arrS(j, 4) amp; ":" amp; arrS(j, 7) amp; "|1"
            Else
                'add new ranges when they are found and increment the occurrences number (last elem)
                arrInt = Split(dict(arrT(i, 1)), "|")
                dict(arrT(i, 1)) = arrInt(0) amp; ";" amp; arrS(j, 3) amp; ":" amp; _
                        arrS(j, 4) amp; ":" amp; arrS(j, 7) amp; "|" amp; CLng(arrInt(1))   1
            End If
        End If
    Next j
    If boolFound Then
        iRow = Split(dict(arrT(i, 1)), "|")(1)              'extract the number of rows

       arrInt = Split(Split(dict(arrT(i, 1)), "|")(0), ";") 'split the dict item to determine each row
       For R = 0 To iRow - 1
           arrT(i   R, 2) = Split(arrInt(R), ":")(0)        'fill the array values according to their row
           arrT(i   R, 3) = Split(arrInt(R), ":")(1)
           arrT(i   R, 4) = Split(arrInt(R), ":")(2)
       Next
    End If
    boolFound = False 'reinitialize the variable.
                      'Without it, trying to split a null string an error will occur
    arrExcl(k) = arrT(i, 1): k = k   1 'load the processed element in the exclusions array
OverProcessing:
 Next i
 shT.Range("F2:H2").value = arrHeaders 'drop the headers
 Dim sliceArray As Variant 'dim a new array to keep a slice from arrT one
 'nice line to slice a 2D array without iteration...
 sliceArray = Application.Index(arrT, Evaluate("row(1:" amp; UBound(arrT, 1) amp; ")"), _
                                                    Evaluate("COLUMN(" amp; "B:D" amp; ")"))
 'drop the processed (sliced) array:
 shT.Range("E3").Resize(UBound(sliceArray, 1), UBound(sliceArray, 2)).value = sliceArray
 MsgBox "Ready..."
End Sub
  

Он возвращает в диапазоне «E2: H» последнюю строку в столбце «C: C». Если после тестирования все работает так, как вам нужно, вы можете изменить диапазон, куда возвращаться, даже переписать столбец C: C…