Собрать из большой кучи файлов разной структуры некоторые данные в один - VBA

Option Explicit
 
Sub tt()
Dim col As New Collection
Dim c As Range, i&, x&, shag&, imax&
Dim wb As Workbook, wsh As Worksheet, fso As Object, TheFolder As Object, afile As Object
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
Set wb = ActiveWorkbook
Set wsh = ActiveSheet
 
imax = 1
 
For Each c In ActiveSheet.[a1].CurrentRegion.Rows(1).Cells
col.Add c.Column, Trim(c)
Next
 
Set fso = CreateObject("Scripting.FileSystemObject")
 
Set TheFolder = fso.GetFolder(wb.Path) 'Каталог
For Each afile In TheFolder.Files
    If UCase(fso.GetExtensionName(afile.Path)) = "XLSX" Then
    Call Zapolnenie(wsh, afile, col, shag, imax)
    End If
Next
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
End Sub
 
Private Sub Zapolnenie(wsh As Worksheet, afile As Object, col As Object, shag As Long, imax As Long)
Dim book As Workbook, sh As Worksheet, r As Range, rr As Range, c As Range
Dim x&, y&, z&, il&, ii&, rrow&, t$
 
 
Set book = Workbooks.Open(afile)
    For Each sh In book.Worksheets
    shag = imax
    With sh
        Set r = .Cells.Find("Характеристики (элементы сравнения)", , xlValues, xlPart)
            If Not r Is Nothing Then
                y = r.Column
                rrow = r.Row
                x = .Cells(rrow, .Columns.Count).End(xlToLeft).Column
                il = .Cells(.Rows.Count, y).End(xlUp).Row
                For Each rr In .Range(.Cells(rrow + 1, y + 1), .Cells(il, x)).Rows
                t = Trim(.Cells(rr.Row, y))
                If Len(t) Then
                ii = shag
                    For Each c In rr.Cells
                        If Len(.Cells(rrow, c.Column)) Then
                        On Error Resume Next
                        z = col(t)
                        If Err <> 0 Then
                        Err.Clear
                        Else
                        'тут копирование
                        'Debug.Print c.Address
                        ii = ii + 1
                        c.Copy wsh.Cells(ii, z)
                        wsh.Cells(ii, 1) = ii - 1
                        imax = Application.Max(imax, ii)
                        End If
                        On Error GoTo 0
                        End If
                    Next
                End If
                Next
            End If
    End With
    Next
    book.Close 0
End Sub