Von mehreren Arbeitsmappen, einen Datenbereich anstelle von Formeln die Werte per VBA in eine andere Arbeitsmappe zusammenführen.

Option Explicit
Option Compare Text

Const ExternPfad = "E:\Threads\$Test\TestToDo"      'Externe Dateien Ordner-Pfad  
Const ExternRange = "A6:F"                          'Externe Dateien Zell-Teilbereich  

Const InternSheet = "Daten-Import"                  'Interne Tabelle für den Import  

Const InternStart = 7                               'Interne Tabelle Start-Zeile  

Const Msg1 = "Bitte Monatszahl (1-12) eingeben:"  
Const Err1 = "Der angegebene Ordner existiert nicht!"  
Const Err2 = "Die Eingabe ist ungültig!"  

Sub GetExternData()
    Dim Wks As Worksheet, Wks0 As Worksheet, WkbX As Workbook, WksX As Worksheet, SheetName As String
    Dim Fso As Object, Folder As Object, File As Object, Monat As Integer, NextLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(ExternPfad) = False Then MsgBox Err1, vbExclamation, "Fehler":  Exit Sub  
    
    Monat = Application.InputBox(Msg1, "Eingabe Monat", "1", Type:=1)  
    
    If Monat <= 0 Then Exit Sub
    
    If Monat > 12 Then MsgBox Err2, vbExclamation, "Fehler": Exit Sub  
    
    SheetName = "*" & GetMonth(Monat) & "*"  
    
    Set Wks0 = ThisWorkbook.Sheets(InternSheet)
    
    Wks0.Range(Rows(InternStart), Rows(Wks0.Rows.Count)).Cells.ClearContents
    
    NextLine = InternStart
    
    Application.ScreenUpdating = False
    
    For Each Folder In Fso.GetFolder(ExternPfad).SubFolders
        For Each File In Folder.Files
            If Fso.GetExtensionName(File) Like "XLS" Then  
                Set WksX = Nothing
                Set WkbX = GetObject(File.Path)
                
                For Each Wks In WkbX.Worksheets
                    If Wks.Name Like SheetName Then Set WksX = Wks:  Exit For
                Next
                                
                If Not WksX Is Nothing Then
                    WksX.Range(ExternRange & GetEndLine(WksX)).Copy
                    Wks0.Cells(NextLine, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                    
                    With Application
                        .DisplayAlerts = False:  WkbX.Close False:  .DisplayAlerts = True
                    End With
                    
                    NextLine = GetEndLine(Wks0) + 2
                End If
            End If
        Next
    Next
    
    Wks0.Cells(InternStart, "A").Select  
    Application.ScreenUpdating = True
End Sub

Private Function GetEndLine(ByRef Wks) As Long
    GetEndLine = Wks.Cells(Wks.Rows.Count, "A").End(xlUp).Row  
End Function

Private Function GetMonth(ByVal M As Integer) As String
    GetMonth = Switch(M = 1, "_Jan", M = 2, "_Feb", M = 3, "_Mär", M = 4, "_Apr", _  
                      M = 5, "_Mai", M = 6, "_Jun", M = 7, "_Jul", M = 8, "_Aug", _  
                      M = 9, "_Sep", M = 10, "_Okt", M = 11, "_Nov", M = 12, "_Dez")  
End Function

Option Explicit
Option Compare Text

Const ExternPfad = "E:\Threads\138203\ToDoListen"   'Externe Dateien Ordner-Pfad  
Const ExternRange = "A?:B?,D?:F?,H?"                'Externe Dateien Zellbereich (?=Per Code Zeilennummer einfügen)  
Const ExternStart = 6                               'Externe Dateien Startzeile  
Const ExternSpalte = "H"                            'Externe Dateien Bezugsspalte (Leer-Test)  

Const InternSheet = "Daten-Import"                  'Interne Tabelle für Import  
Const InternStart = 7                               'Interne Tabelle Startzeile  

Const Msg1 = "Bitte Monatszahl (1-12) eingeben:"  
Const Err1 = "Der angegebene Ordner existiert nicht!"  
Const Err2 = "Die Eingabe ist ungültig!"  

Sub GetExternData()
    Dim Wks As Worksheet, Wks0 As Worksheet, WkbX As Workbook, WksX As Worksheet, SheetName As String
    Dim Fso As Object, Folder As Object, File As Object, Monat As Integer, NextLine As Long, c As Range
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    If Fso.FolderExists(ExternPfad) = False Then MsgBox Err1, vbExclamation, "Fehler":  Exit Sub  
    
    Monat = Application.InputBox(Msg1, "Eingabe Monat", "1", Type:=1)  
    
    If Monat <= 0 Then Exit Sub
    
    If Monat > 12 Then MsgBox Err2, vbExclamation, "Fehler": Exit Sub  
    
    SheetName = "*" & GetMonth(Monat) & "*"  
    
    Set Wks0 = ThisWorkbook.Sheets(InternSheet)
    
    Wks0.Range(Rows(InternStart), Rows(Wks0.Rows.Count)).Cells.ClearContents
    
    NextLine = InternStart
    
    Application.ScreenUpdating = False
    
    For Each Folder In Fso.GetFolder(ExternPfad).SubFolders
        For Each File In Folder.Files
            If Fso.GetExtensionName(File) Like "XLS" Then  
                Set WksX = Nothing
                Set WkbX = GetObject(File.Path)
                
                For Each Wks In WkbX.Worksheets
                    If Wks.Name Like SheetName Then Set WksX = Wks:  Exit For
                Next
                                
                If Not WksX Is Nothing Then
                    
                    WksX.AutoFilterMode = False
                    
                    For Each c In WksX.Rows(ExternStart & ":" & GetEndLine(WksX, ExternSpalte))  
                        If Not IsEmpty(c.Columns(ExternSpalte)) Then
                            WksX.Range(Replace(ExternRange, "?", c.Row)).Copy  
                            Wks0.Cells(NextLine, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats  
                            NextLine = NextLine + 1
                        End If
                    
                    Next
                    
                    With Application
                        .DisplayAlerts = False:  WkbX.Close False:  .DisplayAlerts = True
                    End With
                    
                    NextLine = GetEndLine(Wks0, "A") + 2  
                End If
            End If
        Next
    Next
    
    Wks0.Cells(InternStart, "A").Select  
    Application.ScreenUpdating = True
End Sub

Private Function GetEndLine(ByRef Wks, ByVal Col As Variant) As Long
    GetEndLine = Wks.Cells(Wks.Rows.Count, Col).End(xlUp).Row
End Function

Private Function GetMonth(ByVal M As Integer) As String
    GetMonth = Switch(M = 1, "_Jan", M = 2, "_Feb", M = 3, "_Mär", M = 4, "_Apr", _  
                      M = 5, "_Mai", M = 6, "_Jun", M = 7, "_Jul", M = 8, "_Aug", _  
                      M = 9, "_Sep", M = 10, "_Okt", M = 11, "_Nov", M = 12, "_Dez")  
End Function

Const ExternSpalteH = "H"                           'Externe Dateien Spalte H (Test Leer)  

Const ExternSpalteJ = "J"                           'Externe Dateien Spalte J (Test Wert 0)  

                    For Each c In WksX.Rows(ExternStart & ":" & GetEndLine(WksX, ExternSpalteH))  
                        If Not IsEmpty(c.Columns(ExternSpalteH)) And c.Columns(ExternSpalteJ) <> 0 Then

                    For Each c In WksX.Rows(ExternStart & ":" & GetEndLine(WksX, ExternSpalteJ))  
                        If c.Columns(ExternSpalteJ) <> 0 Then

                    For Each c In WksX.Rows(ExternStart & ":" & GetEndLine(WksX, ExternSpalte))  
                        If Not IsEmpty(c.Columns(ExternSpalte)) Then

                    For Each c In WksX.Rows(ExternStart & ":" & GetEndLine(WksX, ExternSpalteH))  
                        If Not IsEmpty(c.Columns(ExternSpalteH)) And c.Columns(ExternSpalteJ) <> 0 Then                    

                    For Each c In WksX.Rows(ExternStart & ":" & GetEndLine(WksX, ExternSpalteJ))  
                        If c.Columns(ExternSpalteJ) <> 0 Then

                        If c.Columns(ExternSpalteJ) <> 0 Then

                        If Fix(c.Columns(ExternSpalteJ)) <> 0 Then