Страницы: 1
RSS
Подсчет суммы литров по каждому виду топлива
 
Доброго времени суток, друзья!

Будь добры, подскажите, пожалуйста, как посчитать сколько в таблице всего литров топлива каждого из видов топлива?
Реализация необходимо именно через VBA.

Файл в приложении.
Спасибо!


UPD: Необходимы порядок сортировки:

Аи-92
Аи-95
G-95
ДТ
G-Drive 100
СУГ
Изменено: falmrom - 21.08.2019 17:05:43
Улыбнись.
 
Цитата
falmrom написал:
Реализация необходимо именно через VBA
Упорно создаем трудности. Вместо сводной, которая сделает все быстро, без шума и пыли, городить словарь или коллекцию сортировать ….
По вопросам из тем форума, личку не читаю.
 
БМВ, спасибо за подсказку, но концепция полного решения заключается именно в том, чтобы была полная реализация только путем использования VBA, без запросов и подключений.
Изменено: falmrom - 21.08.2019 14:36:03
Улыбнись.
 
А формулы Вам не подходят?
 
Вот тут Mershik великолепно решил схожую задачу обычной формулой, так что может быть огород с VBA и не нужен?
Я не волшебник, я только учусь.
 
Цитата
Wiss написал:
Mershik великолепно решил схожую задачу обычной формулой
правда если докрутить еще и сортировку уникальных, то при большом количестве данных будет некоторое подтупливание.
По вопросам из тем форума, личку не читаю.
 
Цитата
falmrom написал:
полная реализация только путем использования VBA
вы бы хоть показали какой результат на выходе хотите увидеть
Соблюдение правил форума не освобождает от модераторского произвола
 
falmrom, вот тут вывод уникальных- а там прикрутить еще подсчет суммы по условию.  
Не бойтесь совершенства. Вам его не достичь.
 
falmrom, Вы можете почистить свой профиль?
 
Настя_Nastya, нужен именно код vba.
Wiss, бесспорно, решение отличное, но у меня уже настроено все на словарь и его ключи необходимо сортировать по алфавиту
Mershik, подсчет суммы по каждому виду - есть! Необходимо организовать сортировку по ключу (по виду топлива)
vikttur, есть!
Улыбнись.
 
Решение:
Код
Sub ВидыТопливаЛитрыСредняяЦена()
  
 Sheets("ГПН").Select
'===============Создаем словарь===========
Dim dic
Set dic = CreateObject("Scripting.Dictionary") 'создаем словарь

   dic.CompareMode = TextCompare ' текстовый режим - игнорирует регистр
    
    
For i = 2 To Cells(Rows.Count, 3).End(xlUp).row 'цикл с ДВАДЦАТОЙ строки листа до последней заполненной
    If Range("B" & i) <> "" Then
            k = Range("D" & i) 'создаем ключ для словаря сцепкой ячеек. Все ключи в словаре уникальны
            it = Range("E" & i) 'значение по ключу, в примере - количество
                        If dic.Exists(k) Then 'проверяем, есть ли уже такой ключ в словаре
                          dic.item(k) = dic.item(k) + it 'если есть, суммируем колличество с тем, что уже было ранее
                        Else
                          dic.Add k, it 'если нет, делаем в словаре новую запись
                        End If
    End If
Next
  
Rows("1:" & dic.Count + 7).Insert 'вставляем сверху строки

СтрокаВыгрузки = 1 'строка формирования заголовка и первая строка для выгрузки данных
Range("A" & СтрокаВыгрузки) = "Вид топлива"
Range("B" & СтрокаВыгрузки) = "Кол-во л."

i = СтрокаВыгрузки + 1 'с этой строки будем выгружать данные из словаря
For Each ky In dic.keys 'цикл переборки всех записанных ключей
    ar = ky 'разделяем сцепку обратно, получаем два элемента
    Range("A" & i) = ar 'записываем эти элементы в ячейки
    Range("B" & i) = dic.item(ky) 'записываем в ячейку количество
 
    i = i + 1 'переходим к следующей строке
     
    k = 1
    k = k + 1
 
Next
'Сортировка полученных значений
    Range("A" & СтрокаВыгрузки & ":B" & dic.Count + 1).Select
 
    ActiveWorkbook.Worksheets("ГПН").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ГПН").Sort.SortFields.Add key:=Range("A" & СтрокаВыгрузки + 1 & ":A" & dic.Count + 1), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "Аи-92,Аи-95,G-95,ДТ,G-Drive 100,СУГ", DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ГПН").Sort
        .SetRange Range("A" & СтрокаВыгрузки & ":B" & dic.Count + 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ThisWorkbook.ActiveSheet.Sort.SortFields.Clear

dic.RemoveAll ' удаляем словарь
End Sub
Улыбнись.
 
Цитата
falmrom написал:
Решение:
Сомнительное решение, много лишнего кода  ;)
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
Сомнительное решение,
Согласен
Не устраивает сводная, SQL запрос с GROUP BY , ORDER BY  по виду и и SUM по количеству.
По вопросам из тем форума, личку не читаю.
 
На скорую руку набросал аналог из сообщения №11, сортировал пузырьком, т.к. наименований мало.
Код
Sub main()
    Dim objDic As Object, sht As Worksheet
    Dim txt$, arr(), lrow&, ikey, i&
    
    Set sht = Лист4
    sht.[d:e].ClearContents
    Set objDic = CreateObject("scripting.dictionary")
    lrow = sht.Range("b" & sht.Rows.Count).End(xlUp).Row
    arr = sht.Range("b2:c" & lrow).Value
    For i = 1 To UBound(arr)
        txt = arr(i, 1)
        objDic.Item(txt) = objDic.Item(txt) + arr(i, 2)
    Next i
    Erase arr
    ReDim arr(1 To objDic.Count, 2)
    i = 0
    For Each ikey In objDic.keys
        i = i + 1
        arr(i, 0) = ikey
        arr(i, 1) = objDic.Item(ikey)
    Next ikey
    arr = iSort(arr)
    sht.[d1].Resize(, 2).Value = Array("Товар", "кол-во")
    sht.[d2].Resize(i, 2).Value = arr
End Sub

Function iSort(arr)
    Dim txt, i&, j&, k&
    For i = 1 To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i, 0) > arr(j, 0) Then
                For k = 0 To UBound(arr, 2)
                    txt = arr(i, k)
                    arr(i, k) = arr(j, k)
                    arr(j, k) = txt
                Next k
            End If
        Next j
    Next i
    iSort = arr
End Function
Изменено: Nordheim - 21.08.2019 23:28:10
"Все гениальное просто, а все простое гениально!!!"
 
Скрытый текст


Цикл по именам полей  - самый местозанимающий :-)
ну а сортировку по пользовательскому списку можно прикрутить отдельно, при этом ORDER BY Товар не обязателен.
Скрытый текст
Изменено: БМВ - 22.08.2019 11:36:06
По вопросам из тем форума, личку не читаю.
Страницы: 1
Наверх