Excel: Ordner durchsuchen und bestimmte Zellen als Ergebnis ausweisen

Option Explicit
Option Compare Text

Const SuchPfad = "D:\Testordner"                 
Const SuchName = "*.xls*"                             

Const SuchSpalte = "D"                                    

Const TitelZeile = "FELD A, FELD B, FELD C, FELD D"        
Const StartZeile = 2                                  

Const Msg = "Fehler - Ordner nicht vorhanden!"  

Sub GetExternData()
    Dim Wkb As Workbook, Wks As Worksheet, WksHome As Worksheet
    Dim Fso As Object, File As Object, Found As Range, Search As String, NextLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(SuchPfad) = False Then MsgBox Msg, vbExclamation, "Fehler":  Exit Sub  
   
    Search = InputBox("Bitte Suchbegriff eingeben:", "Suchen...")  
    
    If Search = "" Then Exit Sub  
    
    Application.ScreenUpdating = False
    
    Set WksHome = ThisWorkbook.Sheets(1)
    
    WksHome.Cells.ClearContents
    
    With WksHome.Range("A1:D1")  
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Value = Split(TitelZeile, ",")  
    End With
    
    NextLine = StartZeile
    
    For Each File In Fso.GetFolder(SuchPfad).Files
        If File.Name Like SuchName And Not File.Name Like ThisWorkbook.Name Then
            Set Wkb = Workbooks.Open(File.Path)
            
            For Each Wks In Wkb.Worksheets
                If Not Wks.Columns(SuchSpalte).Find(Search, LookIn:=xlValues, lookat:=xlPart) Is Nothing Then
                    With WksHome.Rows(NextLine)
                        .Columns("A") = ActiveCell  
                        .Columns("B") = File.Name  
                        .Columns("C") = Cells(ActiveCell.Row, ActiveCell.Column + 1)  
                        .Columns("D") = Cells(ActiveCell.Row, ActiveCell.Column + 2)  
                         NextLine = NextLine + 1
                    End With
                End If
            Next
            
            Wkb.Close False
        End If
    Next
    
    WksHome.Columns("A:D").AutoFit  
    
    Application.ScreenUpdating = True
End Sub