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 'конец процедуры

'---------------------------------------------------------------------------------------
' Module    : mGetAllFilefromFolder
' DateTime  : 20.07.2012 13:56
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : http://www.excel-vba.ru/chto-umeet-excel/prosmotret-vse-fajly-v-papke/
'---------------------------------------------------------------------------------------
Option Explicit


Dim vFolders(), lCount As Long
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'заносим полное имя файла в список файлов
        ReDim Preserve vFolders(lCount)
        vFolders(lCount) = sFolder & sFiles
        lCount = lCount + 1
        '================================
        'Открытие книг:
'        'открываем книгу
'        Workbooks.Open sFolder & sFiles
'        'действия с файлом
'        'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru
'        ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
'        ActiveWorkbook.Close True
        sFiles = Dir
    MsgBox sFiles    ' Как вывести весь список ???
    
    Loop
'    Range("A1").Resize(lCount).Value = Application.Transpose(vFolders)
    Application.ScreenUpdating = True
End Sub

If Cells(5, 4) = 0 Then Range("D8:D11").Value = "8"  
If Cells(5, 5) = 0 Then Range("E8:E11").Value = "8"
If Cells(5, 6) = 0 Then Range("F8:F11").Value = "8"
If Cells(5, 7) = 0 Then Range("G8:G11").Value = "8"
If Cells(5, 8) = 0 Then Range("H8:H11").Value = "8"
If Cells(5, 9) = 0 Then Range("I8:I11").Value = "8"
If Cells(5, 10) = 0 Then Range("J8:J11").Value = "8"
If Cells(5, 11) = 0 Then Range("K8:K11").Value = "8"
If Cells(5, 12) = 0 Then Range("L8:L11").Value = "8"
If Cells(5, 13) = 0 Then Range("M8:M11").Value = "8"
If Cells(5, 14) = 0 Then Range("N8:N11").Value = "8"
If Cells(5, 15) = 0 Then Range("O8:O11").Value = "8"
If Cells(5, 16) = 0 Then Range("P8:P11").Value = "8"

ThisWorkbook. Sheets("Форма").Select                               ' Эту строку проходит после того, как добавил ThisWorkbook
ThisWorkbook.Sheets("Форма").Range("A1:D42").Select                ' На этой строке выскакивает ниже описанное сообщение.

ThisWorkbook.Sheets("Лист!").Select                                        ' Эту строку проходит после того, как добавил ThisWorkbook
.Range(.Cells(i, 1), .Cells(i, 60)).Copy Cells (jLastrow + 1, 1)        ' На этой строке выскакивает ниже описанное сообщение.
If .Cells(i, 2) <> "" Then Cells(jLastrow + 1, 2) =.Cells (i, 2)