Sub Consolidate()
Dim iTempWbName As String
Dim Wbk As Workbook
Dim TempWbk As Workbook
Dim iPath As String
'выключаем некоторые параметры для увеличения скорости обработки файла
     With Application
       .ScreenUpdating = False             'отключение обновление экрана
       .Calculation = xlCalculationManual  'отключение пересчёт формул вручную
       .EnableEvents = False               'отключение событий
       .DisplayAlerts = False              'отключение предупреждающих сообщений
     End With
     Set Wbk = ThisWorkbook
      iPath = Wbk.Path & "\"
      'очищаем диапазоны на двух листах
      Wbk.Worksheets("ВСЕГО ЛЕСОВ").Range("D11:R38").ClearContents
      Wbk.Worksheets("Защитные леса - всего").Range("D11:R38").ClearContents
          iTempWbName = Dir(iPath & "*.xls")
       Do While iTempWbName <> ""
         If iTempWbName <> Wbk.Name Then
           Set TempWbk = Workbooks.Open(iPath & iTempWbName, UpdateLinks:=False, ReadOnly:=True)
             TempWbk.Worksheets("ВСЕГО ЛЕСОВ").Range("D11:R38").Copy
             Wbk.Worksheets("ВСЕГО ЛЕСОВ").Range("D11").PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
             TempWbk.Worksheets("Защитные леса - всего").Range("D11:R38").Copy
             Wbk.Worksheets("Защитные леса - всего").Range("D11").PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
           TempWbk.Close savechanges:=False
         End If
           iTempWbName = Dir
       Loop
     With Application
       .ScreenUpdating = True
       .Calculation = xlCalculationAutomatic
       .EnableEvents = True
       .DisplayAlerts = True
     End With
End Sub