Еще вариант макросом. Выгрузка на 1лист ячейка В2
Код |
---|
Sub enstaralпава()
Dim arr1, Tp1, Tp2, i&, j&, k&, dic1, dic2, dic3
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set dic3 = CreateObject("Scripting.Dictionary")
arr1 = Worksheets(2).Cells(2).CurrentRegion
For i = 2 To UBound(arr1)
Tp1 = dic1(arr1(i, 1)): Tp1 = dic2(arr1(i, 2)): dic3(arr1(i, 1) & arr1(i, 2)) = arr1(i, 2)
Next
Tp1 = dic1.Keys: Tp2 = dic2.Keys: ReDim arr1(UBound(Tp2), UBound(Tp1))
Set dic1 = Nothing: Set dic2 = Nothing
For i = 0 To UBound(Tp1): k = 0: For j = 0 To UBound(Tp2)
If dic3.exists(Tp1(i) & Tp2(j)) Then arr1(k, i) = dic3(Tp1(i) & Tp2(j)): k = k + 1
Next: Next
Worksheets(1).Range("B2").Resize(UBound(arr1) + 1, UBound(arr1, 2) + 1) = arr1
End Sub
|
Вероятно надо, чтобы все значения 2 столбца попали в результат а в коде выше во 2 словаре заполняются ключи, поэтому повторяющие значения во 2 столбце не попадут в результат. Надо заменить 8 и 10 строки на
Код |
---|
Tp1 = dic1(arr1(i, 1)): dic2(dic2.Count) = arr1(i, 2): dic3(arr1(i, 1) & arr1(i, 2)) = arr1(i, 2)
Tp1 = dic1.keys: Tp2 = dic2.items: ReDim arr1(UBound(Tp2), UBound(Tp1))
|