Страницы: 1
RSS
VBA. Занести данные в словарь со смещением строки
 
Добрый вечер.
Помогите пожалуйста со словарём.
Как внести данные в Items (Dict4), которые находятся в смещённых ячейках, относительно Keys (Dict1).

Код
Sub Сложить() 'начало процедуры
'объявление переменных
Dim M()              'массив. для ускорения обработки
Dim Dict1 As Object  'словарь. для облегчения поиска уникальных
Dim Dict2 As Object  'словарь. для облегчения поиска уникальных
Dim Dict3 As Object  'словарь. для облегчения поиска уникальных
Dim Dict4 As Object  'словарь. для облегчения поиска уникальных
Dim LR               'последняя занятая строка

Лист1.Select         'перейти на лист
LR = Лист1.Cells(Rows.Count, 3).End(xlUp).Row      'узнать количество строк
M = Лист1.Range(Cells(33, 1), Cells(LR, 11)).Value 'загнать таблицу в массив
Set Dict1 = CreateObject("Scripting.Dictionary")   'объявить словарь1
Set Dict2 = CreateObject("Scripting.Dictionary")   'объявить словарь2
Set Dict3 = CreateObject("Scripting.Dictionary")   'объявить словарь3
Set Dict4 = CreateObject("Scripting.Dictionary")   'объявить словарь4


     For i = 1 To UBound(M)                                     'по всему массиву
        If Dict1.Exists(M(i, 3)) Then                           'если в словаре уже имеется Шифр расценки и код
            Dict1.Item(M(i, 3)) = Dict1.Item(M(i, 3)) + M(i, 6) 'суммировать объём
        Else                                                    'иначе
            Dict1.Add M(i, 3), M(i, 6)  'добавить Шифр расценки и код в первый словарь
            Dict2.Add M(i, 3), M(i, 5)  'добавить Ед. изм. во второй словарь
            Dict3.Add M(i, 3), M(i, 4)  'добавить Наименование работ и затрат в третий словарь словарь
'            Dict4.Add M(i, 3), M(i, 11) 'добавить ВСЕГО затрат в четвёртый словарь
' Вместо M(i, 11) должна быть сумма из (x, 11)! в строке "Всего по позиции:"
        End If 'выход из условия
     Next i    'следующая строка
      
' MsgBox Dict1.Items()(0) ' просмотреть первый items
Лист2.Select 'перейти на лист 2
Лист2.Cells.ClearContents 'очистить лист
Лист2.Range("A1").Resize(Dict1.Count) = Application.Transpose(Dict1.Keys)  'выгрузить Шифр расценки и код
Лист2.Range("B1").Resize(Dict1.Count) = Application.Transpose(Dict2.Items) 'выгрузить Ед. изм.
Лист2.Range("C1").Resize(Dict1.Count) = Application.Transpose(Dict3.Items) 'выгрузить Наименование работ и затрат
Лист2.Range("D1").Resize(Dict1.Count) = Application.Transpose(Dict1.Items) 'выгрузить сумму объёмов работ
'Лист2.Range("E1").Resize(Dict1.Count) = Application.Transpose(Dict4.Items) 'выгрузить сумму ВСЕГО затрат

End Sub 'конец процедуры
 
Покажите в файле-примере желаемый результат
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Покажите в файле-примере желаемый результат
В примере, на Лист2 указано, что при совпадении кодов из столбца 3 Лист1, взять суммы из K11 сложив. (Из строки с "Всего по позиции" данного кода.
Если нет совпадения -  просто суммы из K11.
Макрос в модуле рабочий, но вот как вытянуть суммы с ключом из Dict1 - не понимаю.
Изменено: pitby - 29.01.2019 16:55:49
 
Цитата
pitby написал: Макрос в модуле рабочий, но
Если есть какие-то 'но' значит не совсем правильно  :) . Вы вообще как-то странно со словарями работаете. Зачем Вам их столько? Объясните почему в для шифра 3.20-1-1 в столбец Наименование попало только 'Прокладка воздуховодов из черной, оцинкованной стали и алюминия толщиной 0,5 мм диаметром до 200 мм (ф125 мм)'? Почему именно ЭТО наименование, а не, например '...(ф100 мм)' или '...(ф160 мм)'? Вы понимаете что такое Словарь?
Изменено: Sanja - 29.01.2019 17:14:21
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
Почему именно ЭТО наименование, а не, например '...(ф100 мм)' или '...(ф160 мм)
Потому, что все позиции отслеживаются по коду 3.20-1-1 в данном случае. Их много. и нужно не конкретное точное название, а общее количество и сумма.
Что и вносится в Лист2. А название первое. Оно в оригинале и короче может быть.
С остальными позициями то-же самое.
Цитата
Sanja написал:
Вы понимаете что такое Словарь?
С недавнего времени пытаюсь изучить. Перечитал немного литературы. Вникаю.
Изменено: pitby - 29.01.2019 17:21:21
 
У вас в принципе то данные находятся в удобном для редактирования и поиска формате. Вы загоняете весь КС-2 в массив, затем вашей первой точкой остановки становится третий столбец со значением "3.20-1-1", а от этой точки ищем следующие ориентиры -> ЗП, ЭМ, в т.ч. ЗПМ, МР. Дальше крутим вертим массив как хотим.
Изменено: magistor8 - 29.01.2019 17:30:45
 
Цитата
magistor8 написал:
Дальше крутим вертим массив как хотим.
С массивом у меня есть рабочий пример. Там только суммирование не получается одинаковых позиций. Пока.
А обратился к словарю, так как увидел, что суммирование просто выполнить. Если в одной строке с ключом.!
Как кол-во в столбце 6.
А вопрос в том, чтобы вытянуть сумму из строки "Всего по позиции" соответствующей коду.
 
Прогоните макрос пошагово клавишей F8. Посмотрите какие значения принимают переменные. Количество строк = 79. Границы таблицы для массива - (33,1)х(79,11). Итоговые суммы вообще в него не попадают. Словарь №1 вы же заполняете значениями столбцов 3 и 6 - откуда там будут суммы выделенные желтым цветом? Там сумма по количеству. Я так понимаю у вас путаница по границам и номерами столбцов откуда извлекается информация.
Изменено: Alex_I_S - 29.01.2019 17:40:35
 
Цитата
magistor8 написал:
ЗП, ЭМ, в т.ч. ЗПМ, МР.
Эти значения вообще не нужны. Их бы удалить, да в разных позициях они в разных вариациях бывают. Собственно, они не мешают. Отфильтровываются и не попадают в словарь, кроме строки 2 в Лист2. Берется почему-то.
 
Цитата
pitby написал: А название первое.
Уверены? Или первое попавшееся? Потому что первое это '...(ф100 мм)' :)
Ладно, это в принципе лирика.
Для того что бы Ваш макрос работал как надо желательно, что бы размещение данные в исходной таблице поддавалось какой нибудь логике. В Вашей таблице, в шифре 3.20-11-15, отсутствует объем, что отличает этот раздел от остальных. Возможно это просто недосмотр.
Попробуйте такой код (в исходные данные добавлена строка для Объема)
Код
Sub Сложить()
Dim M(), iArr(), arrAll(), I%, J&         'массив. для ускорения обработки
Dim Dict As Object  'словарь. для облегчения поиска уникальных
With Лист1
    M = .Range(.Cells(31, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, 11)).Value 'загнать таблицу в массив
End With
Set Dict = CreateObject("Scripting.Dictionary")   'объявить словарь
ReDim iArr(0 To 2)
For I = 1 To UBound(M) Step 7
    If Dict.Exists(M(I, 3)) Then
        iArr = Dict(M(I, 3))
        iArr(2) = iArr(2) + M(I + 6, 11)
        Dict(M(I, 3)) = iArr
    Else
        iArr(0) = M(I, 5)
        iArr(1) = M(I, 4)
        iArr(2) = M(I + 6, 11)
        Dict(M(I, 3)) = iArr
    End If
Next
ReDim arrAll(0 To Dict.Count, 0 To 3): I = 0
For Each iKey In Dict.Keys
    arrAll(I, 0) = iKey
    iArr = Dict(iKey)
    For J = 0 To UBound(iArr)
        arrAll(I, J + 1) = iArr(J)
    Next
    I = I + 1
Next
With Лист2
    .Cells.ClearContents 'очистить лист
    .Range("A1").Resize(UBound(arrAll) + 1, 4) = arrAll
End With
End Sub 'конец процедуры
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
в шифре 3.20-11-15, отсутствует объем
Строка 73 F - значение "3"
 
Я Вам про отсутствие СТРОКИ как таковой!!! Сами цифры объема не участвуют в расчетах!
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
iArr(2) = M(I + 6, 11)
Не подходит это выражение. Так как строк может быть больше, меньше, или вообще не быть после строки с кодом, наименованием, кол-ком и объёмом.
Всегда есть только строка "Всего по позиции" (В некоторых актах и их нет, только сумма жирным выделена.
Так, что привязываться нужно только к строке с "Всего по позиции"
А за код спасибо, разберу его конечно-же пристально.
 
Цитата
pitby написал: привязываться нужно только к строке с "Всего по позиции"
и тут же
Цитата
pitby написал: "Всего по позиции" (В некоторых актах и их нет, только сумма жирным выделена
Может лучше Вашу сводную делать из данных, по которым составляется сам Акт? Как Вы планируете ориентироваться в МАССИВЕ по жирному тексту в ЯЧЕЙКЕ?
Согласие есть продукт при полном непротивлении сторон
 
Вот еще вариант:
Код
Sub aaa()
Dim DC As Object, aa As Range, arr(), a&, dt$
Set DC = CreateObject("Scripting.Dictionary")
With Sheets(1)
  Set aa = Intersect(.Rows(31 & ":" & .Cells(Rows.Count, "K").End(xlUp).Row), .UsedRange)
  a = 1
  Do
    Do While Len(aa(a, 3)) = 0 And a < aa.Rows.Count: a = a + 1: Loop
    dt = aa(a, 3)
    If Not DC.exists(dt) And Len(dt) > 0 Then
      DC.Add dt, Array(dt, aa(a, 5).Value, aa(a, 4).Value, aa(a, 6).Value, 0)
    ElseIf Len(dt) > 0 Then
      arr = DC.Item(dt): arr(3) = arr(3) + aa(a, 6): DC.Item(dt) = arr
    End If
    a = a + 1
    Do While aa(a, aa.Columns.Count - 1).Font.Bold <> True And a < aa.Rows.Count: a = a + 1: Loop
    If Len(aa(a, aa.Columns.Count - 1)) > 0 Then
      arr = DC.Item(dt): arr(4) = arr(4) + aa(a, aa.Columns.Count - 1)
      DC.Item(dt) = arr: a = a + 1
    End If
  Loop While a < aa.Rows.Count
End With
arr = DC.items: Sheets(2).UsedRange.Clear
For a = 0 To DC.Count - 1
  With Sheets(2).Cells(a + 2, 1).Resize(1, 5)
    .Value = arr(a): .Borders.LineStyle = 9
    .EntireColumn.AutoFit
  End With
Next
End Sub
 
Цитата
Anchoret написал:
Вот еще вариант:
Спасибо огромное! Пока Ваш вариант, вроде, выполняет свои функции. (Проверю на более большей базе)
Вот только это вариант с массивами, а со словарём пока не видно. А может и не нужно?
Ещё раз СПАСИБО!
 
Цитата
Sanja написал:
Как Вы планируете ориентироваться в МАССИВЕ по жирному тексту в ЯЧЕЙКЕ?
Пока делал таким кодом:
Код
1. For i = 1 To iLastRow
2.    If Cells(i, 11).Font.Bold = True Then
3.        job.Cells(J, 11).Value = s2 ' s2 = ' "Всего по позиции:" - записываем сумму в строку с кодом пасценки
4.        job.Cells(j, 11).Font.Bold = True
5.    End If
6.  Next

и

 For i2 = i + 1 To UBound(myArray)
            If myArray(i2, 1) Like "*Всего по позиции*" Then
                t2 = i2
                Application.Transpose (myArray)
Изменено: pitby - 29.01.2019 21:22:08
 
Цитата
pitby написал: а со словарём пока не видно
А это как же!?
Код
Set DC = CreateObject("Scripting.Dictionary")
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
А это как же!?
В самом начале я писал, что код с массивами у меня почти готов, только суммирование подкачало (спасибо Anchoret, вроде получилось. Проверить пока не могу)
А далее, я попробовал на словарях. Получилось, но без суммы по столбцу 11 в строке "Всего по позиции.".
Вот и поднял вопрос.
 
Цитата
Sanja написал:
А это как же!? 1 Set DC = CreateObject("Scripting.Dictionary")
Да, прошу прощения, в торопях и не осознал, что словарь присутствует.
Цитата
Anchoret написал:
Вот еще вариант:
Спасибо огромное ещё раз.
Немного разобрался с вашим кодом, прикрутил под себя, и получилось ТО, ЧТО НУЖНО!
Работает на много быстрее, чем мой приведённый код. И главное - правильно!


Спасибо всем. Тема закрыта.
Страницы: 1
Наверх