Подгрузка данных из нескольких таблиц в одну

Option Explicit
 
Sub myConsolidate()
  Dim fto
  Dim wbThis As Workbook, wb As Workbook, wsMy As Worksheet, ws As Worksheet
  Dim i&, j%, sWbName$, sShtName$, sColName$, sRegName$
  Dim sText$, c As Range, cMy As Range, cRegion As Range, lr&
  
  On Error Resume Next
  
  Set wbThis = ThisWorkbook
  Set wsMy = wbThis.Worksheets("my")
  Application.ScreenUpdating = False
  
  If Len(wsMy.[myPath].Value) Then ChDir wsMy.[myPath].Value
  fto = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="выберите файлы с регионами")
  If TypeName(fto) = "Boolean" Then
    MsgBox "файл(ы) не выбран(ы)!"
    GoTo ExitHandler
  End If
  
  For i = 1 To UBound(fto)
    Workbooks.Open Filename:=fto(i)
    Set wb = ActiveWorkbook: sRegName = Left(wb.Name, Len(wb.Name) - 4)
    Set ws = wb.Worksheets(1)
    For j = 2 To wsMy.[myTable].Rows.Count
      If wsMy.[myTable].Cells(j, 1) = "" Then Exit For
      sShtName = wsMy.[myTable].Cells(j, 1).Value
      sColName = wsMy.[myTable].Cells(j, 2).Value
      sText = wsMy.[myTable].Cells(j, 3).Value
      Set c = ws.UsedRange.Find(what:=sText, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
      If c Is Nothing Then Exit For
      With wbThis.Worksheets(sShtName)
        Set cMy = .Rows(2).Find(what:=sColName)
        If cMy Is Nothing Then Exit For
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lr < 5 Then
          lr = 5
        Else
          Set cRegion = .Range(.[a4], .Cells(lr, 1)).Find(what:=sRegName)
          If cRegion Is Nothing Then lr = lr + 1 Else lr = cRegion.Row
        End If
        .Cells(lr, 1).Value = sRegName
        .Cells(lr, cMy.Column).Resize(1, 6).Value = ws.Cells(c.Row, 7).Resize(1, 6).Value
      End With
    Next
    wb.Close False
  Next
ExitHandler:
End Sub

.Cells(lr, cMy.Column).Resize(1, 6).Value = ws.Cells(c.Row, 7).Resize(1, 6).Value