Sub CopyRanges()
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim iSh As Worksheet
Dim lRow&, I&, N&
Dim arrAddress(), arrShName(), arrMissing(), arrAddSh()
Dim dic As Object, dicExc As Object, dicShTarget As Object, dicShSource As Object
Dim iKey, iTmp
Dim blnOpen As Boolean

On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Set wbTarget = ThisWorkbook               'файл-приемник (эта книга)
Set wbSource = Workbooks("Источник.xls")  'файл-источник (если открыт)
blnOpen = False

'если файл-источник закрыт, открываем его
If wbSource Is Nothing Then
  Set wbSource = Workbooks.Open(wbTarget.Path & Application.PathSeparator & "Источник.xls")
  blnOpen = True
End If
wbTarget.Activate

'список адресов диапазонов для копирования
arrAddress = Array("R24:T81", "W24:X81", "AA24:AB81", "AE24:AF81", "AH22:AH23", "AJ24:AK81", "AN24:AO81", "AQ24:AS81")

'словарь имен листов, исключаемых из обработки
Set dicExc = CreateObject("Scripting.Dictionary")
  dicExc.Add "Разноска", Empty
  dicExc.Add "Расценки", Empty
  dicExc.Add "Итог", Empty
  dicExc.Add "_", Empty
'---------------------------------------------
'словарь имен листов Приемника
Set dicShTarget = CreateObject("Scripting.Dictionary")
For Each iSh In wbTarget.Worksheets
  iTmp = dicShTarget.Item(iSh.Name)
Next
'---------------------------------------------
'словарь имен листов в списке
Set dic = CreateObject("Scripting.Dictionary")
With wbTarget.Worksheets("Расценки")
  lRow = .Cells(.Rows.Count, "K").End(xlUp).Row
  lRow = IIf(lRow < 28, 28, lRow)
  arrShName = .Range("K28:K" & lRow).Value
End With
For Each iKey In arrShName
  iTmp = dic.Item(iKey)
Next
'---------------------------------------------
'словарь имен листов Источника
Set dicShSource = CreateObject("Scripting.Dictionary")
'---------------------------------------------
ReDim arrMissing(1 To 1)  'массив имен листов отсутствующих в Источнике
ReDim arrAddSh(1 To 1)    'массив имен листов добавленных в Приемник
'---------------------------------------------
For Each iSh In wbSource.Worksheets
  iKey = iSh.Name
  If Not dicExc.Exists(iKey) Then
    If Not dicShTarget.Exists(iKey) Then
      iTmp = MsgBox("В файле 'Приемник.xls' отсутствует лист '" & iKey & "'. Копировать лист?", vbExclamation + vbYesNo, "Внимание!")
      If iTmp = vbYes Then
        iSh.Copy before:=wbTarget.Worksheets("Итог")
        N = N + 1
        ReDim Preserve arrAddSh(1 To N)
        arrAddSh(N) = iKey
      End If
    Else
      For Each iTmp In arrAddress
        wbSource.Worksheets(iKey).Range(iTmp).Copy
        wbTarget.Worksheets(iKey).Range(iTmp).PasteSpecial Paste:=xlPasteValues
      Next
    End If
    iTmp = dicShSource.Item(iKey)
  End If
Next
If blnOpen Then wbSource.Close False
For Each iKey In dic.keys
  If Not dicExc.Exists(iKey) Then
    If Not dicShSource.Exists(iKey) Then
      MsgBox "В файле 'Источник.xls' отсутвует лист '" & iKey & "'"
      I = I + 1
      ReDim Preserve arrMissing(1 To I)
      arrMissing(I) = iKey
    End If
  End If
Next
With wbTarget.Worksheets("Расценки")
  .Range("O28").Resize(UBound(arrMissing)) = Application.Transpose(arrMissing)
  .Range("M28").Resize(UBound(arrAddSh)) = Application.Transpose(arrAddSh)
  .Activate
End With
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub