Option Explicit
'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=111738&TITLE_SEO=111738-zameshchenie-brenda-na-polnyy-spisok-artikulov-po-brendu&MID=928086#message928086
Sub jjj()
Dim arrActions(): arrActions = ThisWorkbook.Worksheets("Исходные").[A3:D10].Value
Dim arrBG(): arrBG = ThisWorkbook.Worksheets("Исходные").[G3:H13].Value
Dim arrOut(): ReDim arrOut(1 To UBound(arrActions, 1) * UBound(arrBG, 1), 1 To 5)
Dim dictBG As Object
Set dictBG = CreateObject("Scripting.Dictionary"): dictBG.CompareMode = 1
Dim dictG As Object
Dim i&, j&, lCol&, lCntr&: lCntr = 0
For i = 1 To UBound(arrBG, 1)
If dictBG.Exists(arrBG(i, 1)) Then
Set dictG = dictBG(arrBG(i, 1))
Else
Set dictG = CreateObject("Scripting.Dictionary")
End If
If Not dictG.Exists(arrBG(i, 2)) Then
dictG(arrBG(i, 2)) = 1
End If
Set dictBG(arrBG(i, 1)) = dictG
Next i
For i = 1 To UBound(arrActions, 1)
If dictBG.Exists(arrActions(i, 1)) Then
Set dictG = dictBG(arrActions(i, 1))
For j = 0 To dictG.Count - 1
lCntr = lCntr + 1
lCol = 0
lCol = lCol + 1: arrOut(lCntr, lCol) = arrActions(i, 1)
lCol = lCol + 1: arrOut(lCntr, lCol) = dictG.Keys()(j)
lCol = lCol + 1: arrOut(lCntr, lCol) = arrActions(i, 2)
lCol = lCol + 1: arrOut(lCntr, lCol) = arrActions(i, 3)
lCol = lCol + 1: arrOut(lCntr, lCol) = arrActions(i, 4)
Next j
End If
Next i
If lCntr = 0 Then Exit Sub
With Workbooks.Add
With .Worksheets(1)
.Cells(2, 1).Resize(, 5).Value = Array("Бренд", "Артикул", "% скидки", "Начало", "Окончание")
.Cells(2, 1).Resize(, 5).Font.Bold = True
.Cells(3, 1).Resize(lCntr, 5).Value = arrOut
.UsedRange.EntireColumn.AutoFit
End With
End With
End Sub |