Mithilfe eines Makros mehrere Excel-Datein nach einem Begriff durchsuchen und Daten kopieren

Sub SearchAndCopy()
    Dim wsSearch As Worksheet, c As Range, wsTarget As Worksheet, strFind As String, firstAddress As String, arrFiles As Variant, arrSheets As Variant, i As Integer, fso As Object, objShell As Object, TEMP as String, strTempFile as String
    ' Objects erstellen  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    Set objShell = CreateObject("Wscript.Shell")  
    ' Temp-Verzeichnis ermitteln  
    TEMP = objShell.ExpandEnvironmentStrings("%TEMP%")  
    ' Web-Pfade der Dateien in welchen gesucht wird  
    arrFiles = Array("http://www.domain.de/List_aktuell.xlsx","http://www.domain.de/list_alt.xlsx";"http://www.domain.de/list_zukunft.xlsx")  
    'Namen der Sheets in der entsprechenden Reihenfolge der oben angeführten Dateien  
    arrSheets = Array("Basisdaten","Prio 2","Tabelle1")   
    ' Sheet festlegen in das die Daten kopiert werden  
    Set wsTarget = Sheets(1)
    ' Eingabeaufforderung für die Nummer  
    strFind = InputBox("Bitte geben sie Ihre Nummer ein:", "Nummer suchen")  
    ' Screenflicker unterdrücken  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ' Alle Dateien im Array verarbeiten  
    For i = 0 To UBound(arrFiles)
        'Datei in das TEMP-Verzeichnis heruntergeladen  
        strTempFile = TEMP & "\" & fso.GetFileName(arrFiles(i))  
        'Mappe herunterladen  
        If DownloadFile(arrFiles(i), strTempFile) Then
            'Mappe öffnen  
            Set wsSearch = GetObject(strTempFile).Sheets(arrSheets(i))
            'Suche in der Mappe in Spalte B (Wert muss der Zelle muss in diesem Fall komplett übereinstimmen, wenn das nicht gewünscht ist LookAt:= auf xlPart ändern oder Platzhalter (*?) benutzen)  
            With wsSearch.Range("B:B")  
                Set c = .Find(strFind, LookIn:=xlValues, LookAt:=xlWhole)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        ' Eintrag wurde gefunden, kopiere ganze Zeile in Zielsheet in die nächsten freien Zeilen  
                        c.EntireRow.Copy
                        wsTarget.Range("A" & wsTarget.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial xlPasteAll  
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End With
            ' schließe die Mappe  
            wsSearch.Parent.Close False
        Else
            MsgBox "Konnte Mappe von '" & arrFiles(i) & "' wegen eines Fehlers nicht herunterladen", vbExclamation  
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set fso = Nothing
    Set objShell = Nothing
End Sub

'Funktion zum Herunterladen von Dateien  
Function DownloadFile(ByVal strURL As String, ByVal strTarget As String) As Boolean
    On Error GoTo Error
    Dim objhttp As Object, objStream as Object
    Set objhttp = CreateObject("Microsoft.XMLHTTP")  
    Set objStream = CreateObject("ADODB.Stream")  
    With objhttp
        .Open "GET", strURL, False  
        .send
        If .Status = 200 Then
            objStream.Open
            objStream.Type = 1
            objStream.Write .responseBody
            objStream.SaveToFile strTarget, 2
            objStream.Close
            DownloadFile = True
        Else
            DownloadFile = False
        End If
    End With
    Exit Function
Error:
    DownloadFile = False
End Function