[color=red]Есть несколько списков номенклатуры и кол-вом, причем состав номенклатуры может меняться и неупорядочн, как формировать накопительный список ? Пример во вложении.
[color=red]Есть несколько списков номенклатуры и кол-вом, причем состав номенклатуры может меняться и неупорядочн, как формировать накопительный список ? Пример во вложении.vermut
Sub tt() Dim Dict As Object, LRow As Long, LCol As Long, i As Long, j As Long, S As String Set Dict = CreateObject("Scripting.Dictionary") LCol = Cells(6, Columns.Count).End(xlToLeft).Column With Dict For i = 1 To LCol If Cells(5, i) Like "Ñïèñîê*" Then LRow = Cells(Rows.Count, i).End(xlUp).Row - 2 For j = 7 To LRow S = Cells(j, i) If .exists(S) Then _ .Item(S) = .Item(S) + CDbl(Cells(j, i + 1)) _ Else .Add Key:=S, Item:=CDbl(Cells(j, i + 1)) Next End If Next Range("K7").Resize(.Count, 1) = WorksheetFunction.Transpose(.Keys) Range("L7").Resize(.Count, 1) = WorksheetFunction.Transpose(.Items) Application.ScreenUpdating = False With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=Range("K7"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange Range("K7:L13") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("K7").Select Application.ScreenUpdating = True End With End Sub
[/vba] Только поменять диапазон вывода собранных данных, сейчас он в столбцах K и L того же листа, что и данные
Как вариант, макрос на словаре [vba]
Код
Sub tt() Dim Dict As Object, LRow As Long, LCol As Long, i As Long, j As Long, S As String Set Dict = CreateObject("Scripting.Dictionary") LCol = Cells(6, Columns.Count).End(xlToLeft).Column With Dict For i = 1 To LCol If Cells(5, i) Like "Ñïèñîê*" Then LRow = Cells(Rows.Count, i).End(xlUp).Row - 2 For j = 7 To LRow S = Cells(j, i) If .exists(S) Then _ .Item(S) = .Item(S) + CDbl(Cells(j, i + 1)) _ Else .Add Key:=S, Item:=CDbl(Cells(j, i + 1)) Next End If Next Range("K7").Resize(.Count, 1) = WorksheetFunction.Transpose(.Keys) Range("L7").Resize(.Count, 1) = WorksheetFunction.Transpose(.Items) Application.ScreenUpdating = False With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=Range("K7"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange Range("K7:L13") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("K7").Select Application.ScreenUpdating = True End With End Sub
[/vba] Только поменять диапазон вывода собранных данных, сейчас он в столбцах K и L того же листа, что и данныеМВТ