Страницы: 1 2 След.
RSS
Макрос на суммирование значений по критерию с помощью циклов
 
Доброго времени суток.
Пользователи форума попросили ясно выразить суть проблемы. Думаю следующее объяснение будет понятно :)
Нужно с помощью 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
Очень надеюсь на вашу помощь.
Спасибо заранее.
Изменено: loctev - 03.02.2018 14:17:49 (Доступное разьяснение проблемы)
 
Оформите нормально сообщение иначе вам сделают замечание  ;) .
И у меня вопрос смысл использования в вашем коде конструкции
Код
With Worksheets("Sheet1")
'код.....
End With
"Все гениальное просто, а все простое гениально!!!"
 
Код
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 написал: Мне подсказали, что можно выполнить с помощью вложенных циклов
Можно но ЗАЧЕМ? Вам показали код, который НЕ требует доп.действий по подключению сторонних библиотек и будет работать гораздо быстрее, чем, так любимые Вами, вложенные циклы. Вам 'шашечки' или ехать?
Согласие есть продукт при полном непротивлении сторон
 
Я понимаю:) Все можно сделать и с помощью pivota
Но суть задачи в использовании циклов, такое ограничение к сожалению ((
 
Цитата
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
Изменено: loctev - 04.02.2018 00:05:39
 
Вы хотите результат используя только переменную sum?
А как же i и j? это тоже переменные.
"Все гениальное просто, а все простое гениально!!!"
 
Да, конечно.
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 новых категорий? нужно будет на каждую категорию прописывать новую переменную и задавать новый цикл?
Надеюсь верно изложил мысль.
 
Как вы из кучи данных хотите в коде получить только уникальные по столбцу - категории? Это первоочередная задача. Только после этого можно говорить о суммировании.
В чем причина ограничений?
Изменено: Nordheim - 03.02.2018 16:37:23
"Все гениальное просто, а все простое гениально!!!"
 
А тут в чем ошибка?
Код
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]), должна быть заполнена. Но данный метод (без массивов), будет отрабатывать гораздо дольше (на бооольших таблицах), потому как информация  будет браться из ячейки.
"Все гениальное просто, а все простое гениально!!!"
 
Код
If Cells(i, 1) = Cells(i + 1, 1) Then
это что вы сверяете? Две ячейки рядом друг с другом. Зачем? Смысл в цикле
Код
For j=5 to 7
.....код
Next j
"Все гениальное просто, а все простое гениально!!!"
 
Вместо
Код
If Cells(i, 1) = Cells(i + 1, 1) Then

попробуйте
Код
If Cells(i, 1) = Cells(1, j) Then
Изменено: Nordheim - 03.02.2018 16:48:00
"Все гениальное просто, а все простое гениально!!!"
 
А это
Код
sum = 0
  For j = 5 To 7  
    For i = 2 To 32

запишите так
Код
For j = 5 To 7
sum = 0  
    For i = 2 To 32
"Все гениальное просто, а все простое гениально!!!"
 
Зачем вообще переменная 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
Изменено: Hugo - 03.02.2018 17:31:07
 
Hugo, Nordheim для более наглядного представления вкладываю пример файла.
Заранее спасибо!
Изменено: loctev - 03.02.2018 22:46:27
 
Цитата
loctev написал:
для более наглядного представления вкладываю пример файла
С этого и нужно начинать.
 
Цитата
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 "последняя заполненная строчка"
И можно ли учесть в этом вложенном цикле еще и возможность появления новой категории и также вывести сумму по ней в следующей ячейке с наименованием (без ручного ввода)?
 
Код
Range("a" & Rows.Count).End(xlUp).Row
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
loctev написал:
И можно ли учесть в этом вложенном цикле еще и возможность появления новой категории и также вывести сумму по ней в следующей ячейке с наименованием (без ручного ввода)?
Без использования коллекций или словарей наверно можно но будет сложнее код
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim
Спасибо большое! Вроде работает.
Касательно вопроса по новой категории: А если в тот же цикл добавить приравнивание новой категории к ячейке +1? то есть если для итоговых ячеек - Шапки [E2], Брюки [F2], Шарфы [G2] добавится новая например Пиджаки [H2], то есть columnindex + 1?? Возможно?
 
Нужно смотреть пример кода, я так не смогу сказать. Я не ориентируюсь на ваши записи.
"Все гениальное просто, а все простое гениально!!!"
 
Вы мой код пробовали?
Посмотрел файл - нужно переделывать чтоб учитывало шапку, и что изменились условия вывода - не вертикально, а горизонтально.
Но это уж сами - Ваш косяк :)
Изменено: Hugo - 04.02.2018 01:46:49
 
Цитата
Nordheim написал:
Без использования коллекций или словарей
работает мой вариант, и добавляет все новые, и совсем не сложно. Вероятно потому и не пользуется доверием, что там всего 2 строки в двух циклах :)
 
Цитата
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 - 04.02.2018 13:19:50
 
Hugo
Пробовал, но получилось не то.
Он просто копирует все категории в отдельные поля, не суммирует
 
Зачем в цикле лишних 9997 раз проверяете совпадение ячеек? Времени не жалко?
По остальному я уже выше всё сказал.
 
Цитата
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 :)
Изменено: Hugo - 04.02.2018 13:42:45
Страницы: 1 2 След.
Наверх