Доброго времени суток. Пользователи форума попросили ясно выразить суть проблемы. Думаю следующее объяснение будет понятно Нужно с помощью VBA посчитать суммы по определенным критериям. Например, есть два поля: Категория и Кол-во. Напротив каждой категории есть кол-во. Шапки 100 шт Шарфы 150 шт Шапки 78 шт Брюки 20 шт Шарфы 10 шт Брюки 18 шт В результате должно получится три ячейки с суммами по каждой категории, то есть: Шапки 178 Шарфы 160 Брюки 38 Это своего рода очень похоже на сводную таблицу, но сводной пользоваться запрещено и задачу проделать нужно с помощью макроса с использованием вложенных циклов и предусмотреть возможность добавления новой категории, то есть например если появится новая категория то должна появится новая ячейка с суммой по этой категории (все в точности как в сводной). Специальными функциями в роде worksheet.sum пользоваться нельзя, все только через циклы. С помощью гугла получилось сделать следующее, но как оказалось промежуточная сумма sum должна быть только одна, а не несколько, плюс я подозреваю тут есть много лишнего:) :
Код
Private Sub CommandButton3_Click()
Dim i As Integer, j As Integer, k As Integer
Dim sumsc As Double
Dim sumc As Double
Dim sumf As Double
Dim iLastRow As Long
sumsc = 0
sumc = 0
sumf = 0
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
With Worksheets("Sheet1")
For i = 2 To iLastRow
If Cells(i, 1) = [E1] And IsNumeric(Cells(i, 2)) Then
sumsc = sumsc + Cells(i, 2)
End If
Next i
For j = 2 To iLastRow
If Cells(j, 1) = [F1] And IsNumeric(Cells(j, 2)) Then
sumc = sumc + Cells(j, 2)
End If
Next j
For k = 2 To iLastRow
If Cells(k, 1) = [G1] And IsNumeric(Cells(k, 2)) Then
sumf = sumf + Cells(k, 2)
End If
Next k
[E2] = sumsc
[F2] = sumc
[G2] = sumf
End With
End Sub
Sub test()
Dim arr(), i&, dic As Object
With Sheet1
i = .Range("b" & .Rows.Count).End(xlUp).Row
arr = .Range(.[a2], .Range("b" & i)).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
With dic
For i = 1 To UBound(arr)
.Item(CStr(arr(i, 1))) = .Item(CStr(arr(i, 1))) + arr(i, 2)
Next i
Sheet1.Range("e1").Resize(, .Count) = .keys
Sheet1.Range("e2").Resize(, .Count) = .items
End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
loctev написал: Мне подсказали, что можно выполнить с помощью вложенных циклов
Можно но ЗАЧЕМ? Вам показали код, который НЕ требует доп.действий по подключению сторонних библиотек и будет работать гораздо быстрее, чем, так любимые Вами, вложенные циклы. Вам 'шашечки' или ехать?
Согласие есть продукт при полном непротивлении сторон
разрешаются вложенные циклы, условия if then, массивы.
Есть еще ограничение по промежуточной переменной sum - она должна быть одна. Я так полагаю поэтому и разрешается использовать вложенные циклы. сейчас пробую сделать так, но почему то неправильно считает:
Код
Sub Macro1()
Dim sum As Double
sum = 0
For j = 5 To 7
For i = 2 To 32
If Cells(i, 1) = Cells(i + 1, 1) Then
sum = sum + Cells(i, 2)
End If
Next i
Cells(2, j) = sum
Next j
End Sub
Да, конечно. I, j - счетчики, на них нет ограничений Есть ограничение на sum, в том смысле как на переменную, хранящую промежуточную сумму в выполнении цикла. Я к тому что, не должно быть столько sumов сколько и категорий. Должна быть одна промежуточная переменная sum. Например у нас 3 категории и для суммирования каждой категории я сделал на каждую категорию по одной переменной то есть, например sumShapkи, sumSharfy, sumBryuki) что не есть правильно. А потом просто взял эти 3 суммы присвоил ячейкам, где должен быть результат по каждой категории . Вот кусок этого кода:
Код
Dim i As Integer, j As Integer, k As Integer
Dim sumsc As Double
Dim sumc As Double
Dim sumf As Double
Dim iLastRow As Long
sumsc = 0
sumc = 0
sumf = 0
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
With Worksheets("Sheet1")
For i = 2 To iLastRow
If Cells(i, 1) = [E1] And IsNumeric(Cells(i, 2)) Then
sumsc = sumsc + Cells(i, 2)
End If
Next i
For j = 2 To iLastRow
If Cells(j, 1) = [F1] And IsNumeric(Cells(j, 2)) Then
sumc = sumc + Cells(j, 2)
End If
Next j
For k = 2 To iLastRow
If Cells(k, 1) = [G1] And IsNumeric(Cells(k, 2)) Then
sumf = sumf + Cells(k, 2)
End If
Next k
[E2] = sumsc
[F2] = sumc
[G2] = sumf
End With
Сразу задается вопрос, а если будет 20 новых категорий? нужно будет на каждую категорию прописывать новую переменную и задавать новый цикл? Надеюсь верно изложил мысль.
Как вы из кучи данных хотите в коде получить только уникальные по столбцу - категории? Это первоочередная задача. Только после этого можно говорить о суммировании. В чем причина ограничений?
Sub Macro1()
Dim sum As Double
sum = 0
For j = 5 To 7
For i = 2 To 32
If Cells(i, 1) = Cells(i + 1, 1) Then
sum = sum + Cells(i, 2)
End If
Next i
Cells(2, j) = sum
Next j
End Sub
В данном случае можно и циклами, но строка с категориями ([e1] .....[...1]), должна быть заполнена. Но данный метод (без массивов), будет отрабатывать гораздо дольше (на бооольших таблицах), потому как информация будет браться из ячейки.
"Все гениальное просто, а все простое гениально!!!"
Зачем вообще переменная sum? Думаю сперва нужно продумать алгоритм, затем уже писать код. Например: -до цикла копируем первую вещь в другой пустой диапазон/результат --цикл по исходнику ---вложенный цикл по currentregion первой ячейки результата (по первому столбцу), если название совпадает - суммируем количества, выход из вложенного цикла Вроде всё. P.S. Нет, ещё нужно продумать как все вещи накопировать... Продумал:
Код
Sub tt()
Dim x, y, flag As Boolean
[a1].Copy [e1]
For Each x In [a1].CurrentRegion.Columns(1).Cells
flag = False
For Each y In [e1].CurrentRegion.Columns(1).Cells
If x = y Then y.Offset(, 1) = y.Offset(, 1) + x.Offset(, 1): flag = True: Exit For
Next
If Not flag Then x.Resize(, 2).Copy Cells([e1].CurrentRegion.Rows.Count + 1, 5)
Next
End Sub
Т.к. примера нет - писал на своём, без шапки, на листе только список в два столбца Шапки 100 Шарфы 150 Шапки 78 Брюки 20 Шарфы 10 Брюки 18
Можно ещё добавить столбец с "шт", но он не копируется в сводный в этой реализации, но можно конечно легко добавить. Вот с "шт":
Код
Sub tt()
Dim x, y, flag As Boolean
[a1].Resize(, 3).Copy [e1]: [f1].Clear 'можно без этой строки, но будет сдвиг сводной таблицы
For Each x In [a1].CurrentRegion.Columns(1).Cells
flag = False
For Each y In [e1].CurrentRegion.Columns(1).Cells
If x = y Then y.Offset(, 1) = y.Offset(, 1) + x.Offset(, 1): flag = True: Exit For
Next
If Not flag Then x.Resize(, 3).Copy Cells([e1].CurrentRegion.Rows.Count + 1, 5)
Next
End Sub
Nordheim написал: А это sum = 0 For j = 5 To 7 For i = 2 To 32 запишите так For j = 5 To 7sum = 0 For i = 2 To 32
А как сделать конец цикла не фиксированным, а до последней заполненной строки? То есть не To 32 а To "последняя заполненная строчка" И можно ли учесть в этом вложенном цикле еще и возможность появления новой категории и также вывести сумму по ней в следующей ячейке с наименованием (без ручного ввода)?
loctev написал: И можно ли учесть в этом вложенном цикле еще и возможность появления новой категории и также вывести сумму по ней в следующей ячейке с наименованием (без ручного ввода)?
Без использования коллекций или словарей наверно можно но будет сложнее код
"Все гениальное просто, а все простое гениально!!!"
Nordheim Спасибо большое! Вроде работает. Касательно вопроса по новой категории: А если в тот же цикл добавить приравнивание новой категории к ячейке +1? то есть если для итоговых ячеек - Шапки [E2], Брюки [F2], Шарфы [G2] добавится новая например Пиджаки [H2], то есть columnindex + 1?? Возможно?
Вы мой код пробовали? Посмотрел файл - нужно переделывать чтоб учитывало шапку, и что изменились условия вывода - не вертикально, а горизонтально. Но это уж сами - Ваш косяк
Nordheim написал: Нужно смотреть пример кода, я так не смогу сказать. Я не ориентируюсь на ваши записи.
Вот код:
Код
Dim sum As Double
For j = 5 To 7
sum = 0
For i = 2 To 1000
If Cells(i, 1) = Cells(1, j) Then
sum = sum + Cells(i, 2)
End If
Next i
Cells(2, j) = sum
Next j
End Sub
Nordheim Но как я и говорил нужно допилить код с возможностью появления новой категории с заголовком и суммой в отдельной ячейки
loctev написал: Пробовал, но получилось не то. Он просто копирует все категории в отдельные поля, не суммирует
- значит плохо читали то что я Вам написал - т.к. файла не дали, то писал на своём, описание которого есть в теме. Всё работает без проблем.
P.S. Вот подогнал код под файл из темы:
Код
Sub tt()
Dim x, y, flag As Boolean
For Each x In [a1].CurrentRegion.Columns(1).Offset(1).Cells
flag = False
For Each y In [e1].CurrentRegion.Rows(1).Cells
If x = y Then y.Offset(1) = y.Offset(1) + x.Offset(, 1): flag = True: Exit For
Next
If Not flag Then x.Resize(, 2).Copy: Cells(1, [e1].CurrentRegion.Columns.Count + 4).PasteSpecial Transpose:=True
Next
End Sub
Предварительной очистки диапазона нет! Есть правда одна промежуточная переменная, но это не sum