Все доброй ночи! В очередной раз морочусь с автоматизацией рабочего процесса, но знаний никаких, а готового решния не нашел. Есть таблица с 4 колонками в которых распалагаются - код товара, - его наименование товара - страна производства - вес Задача объединить по всей таблице построчно одинаковые коды с одинаковыми странами производства и суммировать их вес. Наименование неважно и берется из любой объединяемой строки . Сейчас это все делается вручную через фильтр: сначал выбираются одинаковые коды, потом страна. Заетм копируется первая в списке отсоритрованная строка и вставляется ставляем в новую таблицу. Вручную суммируеся общий вес и добавляется в новую таблицу. Было еще терпимо, когда были стаблицы на 20-строк. Но постепенно они становятся все длинее и длиннее и окончательно доканала полученная сегодня 200 строчная таблица, которая в итоге ужалась до 40 строк. В общем времени тратиться много и бестолково. Уверен, что нужный результат можно получить за пару секунд при помощи уже существующего макроса - задача то в общем типовая. По честному потратил 3 вечера на поиски готовых решений - ничего подходящего не обнаружил. Пытался ради интереса сам "слепить". Получается полная фигня - не работает и подвешивает exel. В общем в очердной раз требуется помощь участников этого форума. Пример с исходной таблицей и таблицей с конечным результатмо прилагаю
Все доброй ночи! В очередной раз морочусь с автоматизацией рабочего процесса, но знаний никаких, а готового решния не нашел. Есть таблица с 4 колонками в которых распалагаются - код товара, - его наименование товара - страна производства - вес Задача объединить по всей таблице построчно одинаковые коды с одинаковыми странами производства и суммировать их вес. Наименование неважно и берется из любой объединяемой строки . Сейчас это все делается вручную через фильтр: сначал выбираются одинаковые коды, потом страна. Заетм копируется первая в списке отсоритрованная строка и вставляется ставляем в новую таблицу. Вручную суммируеся общий вес и добавляется в новую таблицу. Было еще терпимо, когда были стаблицы на 20-строк. Но постепенно они становятся все длинее и длиннее и окончательно доканала полученная сегодня 200 строчная таблица, которая в итоге ужалась до 40 строк. В общем времени тратиться много и бестолково. Уверен, что нужный результат можно получить за пару секунд при помощи уже существующего макроса - задача то в общем типовая. По честному потратил 3 вечера на поиски готовых решений - ничего подходящего не обнаружил. Пытался ради интереса сам "слепить". Получается полная фигня - не работает и подвешивает exel. В общем в очердной раз требуется помощь участников этого форума. Пример с исходной таблицей и таблицей с конечным результатмо прилагаюSerge1400
Sub ertert() Dim x, y(), i&, j&, k&, s$, n& x = Range("A2").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To UBound(x, 2))
On Error Resume Next With New Collection For i = 3 To UBound(x) s = x(i, 2) & "~" & x(i, 4) If IsEmpty(.Item(s)) Then k = k + 1: y(k, 1) = k .Add k, s For j = 2 To UBound(x, 2) y(k, j) = x(i, j) Next j Else n = .Item(s) y(n, 5) = y(n, 5) + x(i, 5) End If Next i End With On Error GoTo 0 Range("A15").Resize(k, UBound(x, 2)).Value = y() End Sub
[/vba]
или так [vba]
Код
Sub ertert() Dim x, y(), i&, j&, k&, s$, n& x = Range("A2").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To UBound(x, 2))
On Error Resume Next With New Collection For i = 3 To UBound(x) s = x(i, 2) & "~" & x(i, 4) If IsEmpty(.Item(s)) Then k = k + 1: y(k, 1) = k .Add k, s For j = 2 To UBound(x, 2) y(k, j) = x(i, j) Next j Else n = .Item(s) y(n, 5) = y(n, 5) + x(i, 5) End If Next i End With On Error GoTo 0 Range("A15").Resize(k, UBound(x, 2)).Value = y() End Sub
Serge1400, добрый день,еще вариант макроса,кнопки test и очистка
[vba]
Код
Sub test() Dim z, i&, i1, m& z = Range("A3:E" & Range("A" & Rows.Count).End(xlUp).Row).Value With CreateObject("scripting.dictionary"): .CompareMode = 1 For i = 1 To UBound(z): t = z(i, 2) & z(i, 4) If .exists(t) = False Then m = m + 1: .Item(t) = m: For j = 1 To UBound(z, 2): z(m, j) = z(i, j): Next Else z(.Item(t), 5) = z(.Item(t), 5) + z(i, 5) End If Next Range("G2").Resize(.Count, UBound(z, 2)).Value = z End With i1 = Range("G" & Rows.Count).End(xlUp).Row Range("J" & i1 + 1) = "Èòîãî:" Range("K" & i1 + 1).Formula = "=SUM(K2:K" & i1 & ")" Range("G2").Formula = "1": Range("G3").Formula = "2" Range("G2:G3").AutoFill Destination:=Range("G2:G" & i1), Type:=xlFillDefault End Sub
[/vba]
Serge1400, добрый день,еще вариант макроса,кнопки test и очистка
[vba]
Код
Sub test() Dim z, i&, i1, m& z = Range("A3:E" & Range("A" & Rows.Count).End(xlUp).Row).Value With CreateObject("scripting.dictionary"): .CompareMode = 1 For i = 1 To UBound(z): t = z(i, 2) & z(i, 4) If .exists(t) = False Then m = m + 1: .Item(t) = m: For j = 1 To UBound(z, 2): z(m, j) = z(i, j): Next Else z(.Item(t), 5) = z(.Item(t), 5) + z(i, 5) End If Next Range("G2").Resize(.Count, UBound(z, 2)).Value = z End With i1 = Range("G" & Rows.Count).End(xlUp).Row Range("J" & i1 + 1) = "Èòîãî:" Range("K" & i1 + 1).Formula = "=SUM(K2:K" & i1 & ")" Range("G2").Formula = "1": Range("G3").Formula = "2" Range("G2:G3").AutoFill Destination:=Range("G2:G" & i1), Type:=xlFillDefault End Sub
Всем откликнувшимся большое спасибо! Всем заплюсовал в репутации. Нравится мне этот форум - еще ни разу не было чтоб мне дураку бестолковому не помогли советом и делом. Сегодня несколько раз "покатал" все варианты: все таки по мне вариант макроса интереснеи кажется чем возня с формулами. Вариант sv2014, почему то на многострочных таблицах начинает обвешивать клиограмм на 400, хотя в выложенном примере работает идеально. Причина для меня неизвестна так я в VBA вообще ничего не понимаю. В общем в итоге остановился на варианте предложенном nilem: во всех тестах считает правильно + я смог сообразить что изменить в макросе чтобы итогова талица вставлялась в нужном мне месте. Собственно последующие вопросы будут по макросу nilem, - как добавить в макрос еще два столбца, чтоб и они суммировались по такому же принципу как и веса: то есть при совпадении кода и страны. Помимо того, что это иногда нужно и по работе, интересно было бы и самому разобраться что да как. Поначалу думал, что сам решу, да куда там! Час пялился на текст, но так ничего и не понял. А когда будет возможность сравнить два варианта, то надеюсь пойму что там за что отвечает. Кстати макрос значения из добавленных столбцов подставляет в итоговую табличку из "материнской" строчки, но значения не суммирует. Файл с новым примером с уже реальной рабочей таблицей не заню как приложить - у меня он под 500 кило весит.
Всем откликнувшимся большое спасибо! Всем заплюсовал в репутации. Нравится мне этот форум - еще ни разу не было чтоб мне дураку бестолковому не помогли советом и делом. Сегодня несколько раз "покатал" все варианты: все таки по мне вариант макроса интереснеи кажется чем возня с формулами. Вариант sv2014, почему то на многострочных таблицах начинает обвешивать клиограмм на 400, хотя в выложенном примере работает идеально. Причина для меня неизвестна так я в VBA вообще ничего не понимаю. В общем в итоге остановился на варианте предложенном nilem: во всех тестах считает правильно + я смог сообразить что изменить в макросе чтобы итогова талица вставлялась в нужном мне месте. Собственно последующие вопросы будут по макросу nilem, - как добавить в макрос еще два столбца, чтоб и они суммировались по такому же принципу как и веса: то есть при совпадении кода и страны. Помимо того, что это иногда нужно и по работе, интересно было бы и самому разобраться что да как. Поначалу думал, что сам решу, да куда там! Час пялился на текст, но так ничего и не понял. А когда будет возможность сравнить два варианта, то надеюсь пойму что там за что отвечает. Кстати макрос значения из добавленных столбцов подставляет в итоговую табличку из "материнской" строчки, но значения не суммирует. Файл с новым примером с уже реальной рабочей таблицей не заню как приложить - у меня он под 500 кило весит.Serge1400
Сообщение отредактировал Serge1400 - Суббота, 23.07.2016, 11:43
все 500 кило не надо, достаточно 30-40 (мешок картошки - несколько строк так, как они расположены в реальном файле.
Сделал все заново - получилось 20 кило. Мешок, но маленький :D Выдаю так, как оно будет использоваться. На кнопочке висит ваш макрос, результат работы которого виден в правой итоговой табличке. Ну и результирующие формулы поверх заголовков вставил - так удобнее. Да! И это - обсчитался, блин, маленько по добавляемым колонкам - их три получается. Если вместе с "весом", то 4. P.S. Пардон, в предыдущем сообщении опечатался. Вариант, предложенный sv2014 обсчитывает по весу. Справедливость восстановил.
все 500 кило не надо, достаточно 30-40 (мешок картошки - несколько строк так, как они расположены в реальном файле.
Сделал все заново - получилось 20 кило. Мешок, но маленький :D Выдаю так, как оно будет использоваться. На кнопочке висит ваш макрос, результат работы которого виден в правой итоговой табличке. Ну и результирующие формулы поверх заголовков вставил - так удобнее. Да! И это - обсчитался, блин, маленько по добавляемым колонкам - их три получается. Если вместе с "весом", то 4. P.S. Пардон, в предыдущем сообщении опечатался. Вариант, предложенный sv2014 обсчитывает по весу. Справедливость восстановил.Serge1400
Sub ertert() Dim x, y(), i&, j&, k&, s$, n& x = Range("A3").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To UBound(x, 2))
On Error Resume Next With New Collection For i = 3 To UBound(x) s = x(i, 2) & "~" & x(i, 4) If IsEmpty(.Item(s)) Then k = k + 1: y(k, 1) = k .Add k, s For j = 2 To UBound(x, 2) - 1 y(k, j) = x(i, j) Next j Else n = .Item(s) For j = 5 To 8 y(n, j) = y(n, j) + x(i, j) Next End If Next i End With On Error GoTo 0 With Range("K4").CurrentRegion.Offset(2) .ClearContents .Resize(k).Value = y() End With End Sub
[/vba]
и до кучи
[vba]
Код
Sub ertert() Dim x, y(), i&, j&, k&, s$, n& x = Range("A3").CurrentRegion.Value ReDim y(1 To UBound(x), 1 To UBound(x, 2))
On Error Resume Next With New Collection For i = 3 To UBound(x) s = x(i, 2) & "~" & x(i, 4) If IsEmpty(.Item(s)) Then k = k + 1: y(k, 1) = k .Add k, s For j = 2 To UBound(x, 2) - 1 y(k, j) = x(i, j) Next j Else n = .Item(s) For j = 5 To 8 y(n, j) = y(n, j) + x(i, j) Next End If Next i End With On Error GoTo 0 With Range("K4").CurrentRegion.Offset(2) .ClearContents .Resize(k).Value = y() End With End Sub
Sub мяу() Dim arr, aT(), i&, j&, s$ arr = Range("A3").CurrentRegion.Value ReDim aT(1 To 8) With CreateObject("Scripting.Dictionary") For i = 3 To UBound(arr) s = arr(i, 2) & "|" & arr(i, 4) If .Exists(s) Then aT() = .Item(s) aT(5) = aT(5) + arr(i, 5) aT(6) = aT(6) + arr(i, 6) aT(7) = aT(7) + arr(i, 7) aT(8) = aT(8) + arr(i, 8) .Item(s) = aT Else For j = 2 To 8 aT(j) = arr(i, j) Next aT(1) = .Count + 1: .Item(s) = aT End If Next i Range("K4").CurrentRegion.Offset(2).ClearContents Range("K4").CurrentRegion.Offset(2).Resize(.Count, 8).Value = Application.Index(.Items, 0, 0) End With End Sub
[/vba]
[p.s.]дядя Хьюго любит такие коды :)[/p.s.]
... а Мяу, видимо, имелось ввиду так:
[vba]
Код
Sub мяу() Dim arr, aT(), i&, j&, s$ arr = Range("A3").CurrentRegion.Value ReDim aT(1 To 8) With CreateObject("Scripting.Dictionary") For i = 3 To UBound(arr) s = arr(i, 2) & "|" & arr(i, 4) If .Exists(s) Then aT() = .Item(s) aT(5) = aT(5) + arr(i, 5) aT(6) = aT(6) + arr(i, 6) aT(7) = aT(7) + arr(i, 7) aT(8) = aT(8) + arr(i, 8) .Item(s) = aT Else For j = 2 To 8 aT(j) = arr(i, j) Next aT(1) = .Count + 1: .Item(s) = aT End If Next i Range("K4").CurrentRegion.Offset(2).ClearContents Range("K4").CurrentRegion.Offset(2).Resize(.Count, 8).Value = Application.Index(.Items, 0, 0) End With End Sub
nilem, Воооо! Прям как надо вышло :respect: Спасибо! Пытался сравнить тексты первого и второго макроса - в общем никакого сильного просветления не появилось. Вижу что почти все осталось как и было и только в самом конце небольшая добавка и изменения. В общем моих знаний и мозгов для осознания происходящих процессов явно не хвататет. А можно сделать так, чтоб макрос нолики в пустые ячейки не вставлял в конечной таблице! А то он их выборочно разбросал и от этого страдает мой перфекционизм и красота табличек P.S. Мяу после корректировки тоже заработало!
nilem, Воооо! Прям как надо вышло :respect: Спасибо! Пытался сравнить тексты первого и второго макроса - в общем никакого сильного просветления не появилось. Вижу что почти все осталось как и было и только в самом конце небольшая добавка и изменения. В общем моих знаний и мозгов для осознания происходящих процессов явно не хвататет. А можно сделать так, чтоб макрос нолики в пустые ячейки не вставлял в конечной таблице! А то он их выборочно разбросал и от этого страдает мой перфекционизм и красота табличек P.S. Мяу после корректировки тоже заработало!Serge1400
Sub мяв() Dim arr, aT(), i&, j&, s$ arr = Range("A3").CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) s = arr(i, 1) & "|" & arr(i, 3) If Len(arr(i, 1)) Then ReDim aT(1 To 7) If .Exists(s) Then aT = .Item(s) aT(4) = aT(4) + arr(i, 4) aT(5) = aT(5) + arr(i, 5) aT(6) = aT(6) + arr(i, 6) aT(7) = aT(7) + arr(i, 7) .Item(s) = aT Else For j =1To 7 aT(j) = arr(i, j) Next .Item(s) = aT End If End If Next Range("A40").Resize(.Count, 7) = Application.Transpose(Application.Transpose(.Items)) End With End Sub
[/vba]
Тогда уж так [vba]
Код
Sub мяв() Dim arr, aT(), i&, j&, s$ arr = Range("A3").CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) s = arr(i, 1) & "|" & arr(i, 3) If Len(arr(i, 1)) Then ReDim aT(1 To 7) If .Exists(s) Then aT = .Item(s) aT(4) = aT(4) + arr(i, 4) aT(5) = aT(5) + arr(i, 5) aT(6) = aT(6) + arr(i, 6) aT(7) = aT(7) + arr(i, 7) .Item(s) = aT Else For j =1To 7 aT(j) = arr(i, j) Next .Item(s) = aT End If End If Next Range("A40").Resize(.Count, 7) = Application.Transpose(Application.Transpose(.Items)) End With End Sub