Attribute VB_Name = "Module1" Type ТипКласс Наименование As String Класс As String End Type Public Type ТипКлассРезультат Класс As String Сумма As Double End Type Sub СуммированиеРасходов() Dim nLastRow As Long Dim nLastRow2 As Long Dim val As String Dim массивКлассификаций() As ТипКласс Dim массивРезультат() As ТипКлассРезультат Dim nCountRes As Integer nCountRes = 0 ReDim массивКлассификаций(1) Dim НазваниеСтраницы As String НазваниеСтраницы = ActiveSheet.Name ' MsgBox "Название: " & НазваниеСтраницы & "", , "" ' загрузка классификаций nLastRow2 = Sheets("классификации").Cells(Rows.Count, 1).End(xlUp).Row ReDim массивКлассификаций(nLastRow2) ' MsgBox "nLastRow=A" & nLastRow2, , "" For i = 2 To nLastRow2 Dim Наименование, Класс As String Наименование = Sheets("классификации").Cells(i, 1).Value Класс = Sheets("классификации").Cells(i, 2).Value If Not IsEmpty(Наименование) Then массивКлассификаций(i - 1).Класс = Класс массивКлассификаций(i - 1).Наименование = Наименование End If Next nLastRow = Cells(Rows.Count, 2).End(xlUp).Row ' MsgBox "nLastRow=C" & nLastRow, , "" ' первый проход для дополнения классификаций For i = 1 To nLastRow Dim Название1 As String Название1 = Sheets("" & НазваниеСтраницы).Cells(i, 3).Value If Not IsEmpty(Название1) Then If Not НаименованиеЕстьВМассиве(Название1, массивКлассификаций) Then nLastRow2 = nLastRow2 + 1 ReDim Preserve массивКлассификаций(nLastRow2) массивКлассификаций(nLastRow2).Наименование = Название1 массивКлассификаций(nLastRow2).Класс = "неизвестно" Sheets("классификации").Cells(nLastRow2, 1).Value = массивКлассификаций(nLastRow2).Наименование Sheets("классификации").Cells(nLastRow2, 2).Value = массивКлассификаций(nLastRow2).Класс End If ' MsgBox "Название: " & Название & ", Цена: " & Цена, , "" End If Next ' рассчет результирующего массива For i = 1 To UBound(массивКлассификаций) If nCountRes = 0 Then nCountRes = nCountRes + 1 ReDim Preserve массивРезультат(1) массивРезультат(1).Класс = Класс массивРезультат(1).Сумма = 0# End If If Not IsEmpty(массивКлассификаций(i).Класс) Then If Not КлассЕстьВМассиве(массивКлассификаций(i).Класс, массивРезультат) Then Dim v2 As Integer v2 = UBound(массивРезультат) + 1 ReDim Preserve массивРезультат(v2) массивРезультат(v2).Класс = массивКлассификаций(i).Класс массивРезультат(v2).Сумма = 0 End If End If Next ' подсчет For i = 1 To nLastRow If Not IsEmpty(Cells(i, 3).Value) Then Dim Название, Цена As Double, НайденныйКласс As String Название = Cells(i, 3).Value Цена = Cells(i, 4).Value ' MsgBox "Цена: " & Цена & "", , "" НайденныйКласс = "неизвестно" For k = 1 To UBound(массивКлассификаций) If массивКлассификаций(k).Наименование = Название Then НайденныйКласс = массивКлассификаций(k).Класс End If Next For g = 1 To UBound(массивРезультат) If массивРезультат(g).Класс = НайденныйКласс Then массивРезультат(g).Сумма = массивРезультат(g).Сумма + Цена End If Next End If Next ' очищаем место под данные For i = 1 To Cells(Rows.Count, 11).End(xlUp).Row If IsEmpty(Cells(i + 3, 11).Value) Then Exit For End If Cells(i + 3, 11).Value = "" Cells(i + 3, 12).Value = "" Next ' печать данных For i = 1 To UBound(массивРезультат) Cells(i + 3, 11).Value = массивРезультат(i).Класс Cells(i + 3, 12).Value = массивРезультат(i).Сумма Next End Sub Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1) End Function Function НаименованиеЕстьВМассиве(Наименование As String, классификации() As ТипКласс) As Boolean НаименованиеЕстьВМассиве = False For i = 1 To UBound(классификации) If классификации(i).Наименование = Наименование Then НаименованиеЕстьВМассиве = True End If Next End Function Function КлассЕстьВМассиве(Класс As String, классификации() As ТипКлассРезультат) As Boolean КлассЕстьВМассиве = False For i = 1 To UBound(классификации) If классификации(i).Класс = Класс Then КлассЕстьВМассиве = True End If Next End Function