Форум по VBA и MS Office

Sub Кнопка1_Щелчок()

Application.ScreenUpdating = False

Dim path As String
        path = "C:\Users"
    Dim path1 As String
    Dim temp_name As String
        temp_name = "spec_template_2"
    Dim file_ext As String
        file_ext = ".xlsx"
    Dim spec_names As New Collection 'список всех спецификаций
    Dim dwg_names As New Collection 'список комплектов
    Dim i As Integer
        i = 1
    Dim idx As Dictionary
    Set idx = New Dictionary
    Dim idx_1 As Dictionary ' индекс начальной позиции данных
    Set idx_1 = New Dictionary
    Dim idx_2 As Dictionary ' индекс конечной позиции данных
    Set idx_2 = New Dictionary
    Dim s_sc As Dictionary 'класс безопасности
    Set s_sc = New Dictionary
    Dim s_mcs As New Dictionary 'код MCS
    Set s_mcs = New Dictionary
    Dim s_qa As Dictionary 'категория обеспечения качества
    Set s_qa = New Dictionary
   
        s_qa.Add "4Н", "QNC"
        s_qa.Add "3Н", "QA3"
        s_qa.Add "2О", "QA2"
   
    Dim s_id As New Collection 'артикул
    Dim s_item_name As New Collection 'наименование
    Dim s_qty As New Collection 'количество
    Dim s_unit As New Collection    'размерность
    Dim s_unit_value As New Collection  'единичная стоимость
    Dim s_total_value As New Collection 'общая стоимость
   
   
    Dim iCell As Range
   
    For Each iCell In Range(Sheets(1).Cells(5, "A"), Sheets(1).Cells(Rows.Count, "A").End(xlUp))
    s_id.Add Sheets(1).Cells(iCell.Row, 2).Value
        Dim a() As String
        a = Split(Sheets(1).Cells(iCell.Row, 1).Value, "/")
        If (UBound(a) > 0) Then s_item_name.Add a(0)
        s_qty.Add Sheets(1).Cells(iCell.Row, 8).Value
        s_unit.Add Sheets(1).Cells(iCell.Row, 5).Value
        s_unit_value.Add Sheets(1).Cells(iCell.Row, 7).Value
        's_total_value.Add Sheets(1).Cells(iCell.Row, 7).Value
        's_unit_value.Add s_total_value(s_total_value.Count) / s_qty(s_qty.Count)
       
          If (iCell.Value <> "") Then
            i = 1
            spec_names.Add iCell.Value
            dwg_names.Add Sheets(1).Cells(iCell.Row, 1).Value
          idx.Add iCell.Value, i
            s_sc.Add iCell.Value, Sheets(1).Cells(iCell.Row, 6).Value
            s_mcs.Add iCell.Value, Sheets(8).Cells(iCell.Row, 3).Value
           
            tmp = iCell.Value
        Else
            i = i + 1
            idx.Item(spec_names.Item(spec_names.Count)) = i
        End If
    Next
   
    idx.Remove (spec_names.Item(spec_names.Count))
    s_sc.Remove (spec_names.Item(spec_names.Count))
    spec_names.Remove (spec_names.Count)
    dwg_names.Remove (dwg_names.Count)
   
    s_id.Remove (s_id.Count)
    s_qty.Remove (s_qty.Count)
    s_unit.Remove (s_unit.Count)
    's_total_value.Remove (s_total_value.Count)
    's_unit_value.Remove (s_unit_value.Count)
   
 
    idx_1.Add spec_names(1), 1
    idx_2.Add spec_names(1), idx.Item(spec_names(1))
    For i = 2 To idx.Count
        idx_1.Add spec_names(i), (idx_2.Item(spec_names(i - 1)) + 1)
        idx_2.Add spec_names(i), (idx.Item(spec_names(i)) + idx_2.Item(spec_names(i - 1)))
    Next i
   
    'Запись спецификаций
    For i = 1 To spec_names.Count
   
    Workbooks.Open (path + temp_name + file_ext)
    path1 = path + CStr(spec_names.Item(i)) + file_ext
   
        ActiveWorkbook.Sheets(1).Cells(7, 1).Value = spec_names.Item(i) + " от 18.10.2021" 'Дата документа
        ActiveWorkbook.Sheets(1).Cells(7, 2).Value = dwg_names(i) + " (Класс безопасности " + s_sc.Item(spec_names(i)) + ", категория обеспечения качества " + s_qa.Item(s_sc.Item(spec_names(i))) + ")"
    k = 1
        For j = idx_1.Item(spec_names(i)) To idx_2.Item(spec_names(i))
            ActiveWorkbook.Sheets(1).Cells(11 + k, 1) = k
            ActiveWorkbook.Sheets(1).Cells(11 + k, 2) = s_mcs(j)
            ActiveWorkbook.Sheets(1).Cells(11 + k, 3) = s_id(j)
            ActiveWorkbook.Sheets(1).Cells(11 + k, 4) = s_item_name(j)
            ActiveWorkbook.Sheets(1).Cells(11 + k, 5) = s_qty(j)
            ActiveWorkbook.Sheets(1).Cells(11 + k, 6) = s_unit(j)
            ActiveWorkbook.Sheets(1).Cells(11 + k, 7) = s_unit_value(j) 'Раскоментить для цен
            ActiveWorkbook.Sheets(1).Cells(11 + k, 8) = 0 's_total_value(j)'Раскоментить для цен
            k = k + 1
        Next j
       
        ActiveWorkbook.SaveAs Filename:=path1
        ActiveWorkbook.Close SaveChanges:=False
       
    Next i
   
   
    Application.ScreenUpdating = True
   

End Sub