Zelle Suchen und Vergleichen

Option Explicit
Option Compare Text

Private Const RowTemplate = 2       'Sheet Log-Settings: Überschriftzeile Log-Vorlage  
Private Const RowLogPos1 = 5        'Sheet Log-Settings: Überschriftzeile Log-Type 1  
Private Const OfsLogNext = 4        'Sheet Log-Settings: Überschriftzeile Log-Type n  

Private Const LogMsg1 = "Keine Log-Type-Übereinstimmung gefunden: "  
Private Const LogMsg2 = "Zielspalte doppelt vergeben - Log-Settings Zelladresse: "  
Private Const LogMsg3 = "Ungültige Spaltenangabe - Log-Settings Zelladresse: "  

Private Const LogFile = "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test\Log.txt"   

Private Sub Test()
    Dim objWks As Worksheet, objLogFile As Object, rngPaste As Range, strFileName As Variant
    
    strFileName = "I:\Projects-Global\ITIS\IT37639_Logbuch_Zusammenfuehrung\090_Infos_Intern\Gleiche_Logbuecher_Test\IT37660_Logbuch.xlsx"   
    
    With CreateObject("Scripting.FileSystemObject")  
        Set objLogFile = .CreateTextFile(LogFile)
    End With
    
    Application.ScreenUpdating = False
    
    With Sheets("Vorlage")  
        Set rngPaste = .Range("A5")  
    
        'For Each strFileName In objFileList  
            Set objWks = Workbooks.Open(strFileName, ReadOnly:=True).Sheets(1)
            Call CopyLogData(objWks, rngPaste, objLogFile)
            objWks.Parent.Close False
            
           'Set rngPaste = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)  
        'Next  
        objLogFile.Close
    End With
    Application.ScreenUpdating = True
    MsgBox "Fertig!"  
End Sub

Private Sub CopyLogData(ByRef objWksLog, ByRef rngPaste, ByRef objLogFile)
    Dim objWks As Worksheet, objValues As Object, rngHeader1 As Range, rngCompT As Range
    Dim rngCompL As Range, rngFound As Range, arrInit As Variant, arrValues As Variant
    Dim strCol As String, strLogCol As String, intColsCount As Long, intRowsCount As Long, i As Long
    
    Set objWks = ThisWorkbook.Sheets("Log-Settings")  
    Set rngHeader1 = objWks.Cells(RowLogPos1, "A")  
    
    Do While rngHeader1.Text <> ""  
        Set rngFound = objWksLog.Columns(1).Find(rngHeader1.Value, LookIn:=xlValues, LookAt:=xlWhole)
    
        If Not rngFound Is Nothing Then
            Set rngCompT = Range(rngHeader1, rngHeader1.End(xlToRight))
            Set rngCompL = rngFound.Resize(1, rngCompT.Columns.Count)
            
            If CompareHeader(rngCompT.Value, rngCompL.Value) Then
                Set objValues = CreateObject("Scripting.Dictionary")  
                
                intColsCount = objWks.Cells(RowTemplate, "A").End(xlToRight).Column  
                intRowsCount = objWksLog.Cells(Rows.Count, "A").End(xlUp).Row - rngFound.Row  
                
                If intRowsCount > 0 Then
                    ReDim arrInit(intRowsCount - 1)
                    For i = 1 To intColsCount
                        objValues.Add Chr(Asc("@") + i), arrInit  
                    Next
                
                    For i = 0 To rngCompT.Columns.Count - 1
                        strCol = UCase(rngHeader1.Offset(1, i).Text)
                        
                        If strCol <> "" Then  
                            If objValues.Exists(strCol) Then
                                If InStr(strLogCol, "[" & strCol & "]") < 1 Then  
                                    arrValues = rngFound.Offset(1, i).Resize(intRowsCount, 1).Value
                                    objValues.Item(strCol) = WorksheetFunction.Transpose(arrValues)
                                    strLogCol = strLogCol & "[" & strCol & "]"  
                                Else
                                    objLogFile.WriteLine LogMsg2 & rngHeader1.Offset(1, i).Address
                                End If
                            Else
                                objLogFile.WriteLine LogMsg3 & rngHeader1.Offset(1, i).Address
                            End If
                        End If
                    Next
                End If
                Exit Do
            End If
        End If
        Set rngHeader1 = rngHeader1.Offset(OfsLogNext, 0)
    Loop
    
    If objValues Is Nothing Then
        objLogFile.WriteLine LogMsg1 & objWksLog.Parent.FullName
    ElseIf intRowsCount > 0 Then
        arrValues = WorksheetFunction.Transpose(objValues.Items)
        rngPaste.Resize(UBound(arrValues, 1), UBound(arrValues, 2)).Value = arrValues
    End If
End Sub

Private Function CompareHeader(ByRef aValues1, ByRef aValues2) As Boolean
    Dim c As Long
    
    CompareHeader = True
    For c = 1 To UBound(aValues1, 2)
        If Not aValues1(1, c) Like aValues2(1, c) Then
            CompareHeader = False:  Exit For
        End If
    Next
End Function