Wie einzelne Zellen aus mehreren Excel-Dateien auslesen und in eine neue Datei einfügen?

Option Explicit

Const sXlsPath = "D:\Temp"  
Const iStartZeile = 3
Const iStartSpalte = 1

Const Zellen = "B28,E28,H28,O28,Q28,A30,A31"  


Sub CopyExternData()
    Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As Worksheet
    Dim aCells As Variant, iNextLine As Long, i As Integer
    
    Set oWks0 = ThisWorkbook.ActiveSheet
    
    aCells = Split(Zellen, ","):  iNextLine = iStartZeile  
    
    Set oFso = CreateObject("Scripting.FilesystemObject")  
    
    For Each oFile In oFso.GetFolder(sXlsPath).Files
        If LCase(oFso.GetExtensionName(oFile.Name)) = "xls" Then  
            If ThisWorkbook.Name <> oFile.Name Then
                Set oWkb1 = Workbooks.Open(oFile.Path)
                Set oWks1 = oWkb1.Sheets(1)
                For i = 0 To UBound(aCells)
                    oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells(i))).Value
                Next
                oWkb1.Close False
                iNextLine = iNextLine + 1
            End If
        End If
    Next
End Sub

Option Explicit

Const sXlsPath = "D:\Temp"  
Const iStartZeile = 3           'Diese Arbeitsmappe, Daten ab Zeile  
Const iStartSpalte = 1          'Diese Arbeitsmappe, Daten ab Spalte  

Const iStartCopyZeile = 28      'Externe Arbeitsmappe,Daten ab Zeile (28)  
Const iNextCopyZeile = 100      'Externe Arbeitsmappe,Daten nächste Zeile (+100)  

Sub CopyExternData2()
    Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As Worksheet
    Dim aOfs As Variant, oNextCell As Range, iNextLine As Long, i As Integer
    
    Set oWks0 = ThisWorkbook.ActiveSheet
    Set oFso = CreateObject("Scripting.FilesystemObject")  
    
    'Relative Offset-Adressen (Aktuelle Zeile + ?, Spalte 1 + ?)  
    'Bei aktueller Zeile 28 entspricht dies: B28, E28, H28, O28, Q28, A30, A31  
    aOfs = Array(Array(0, 1), _
                 Array(0, 4), _
                 Array(0, 7), _
                 Array(0, 14), _
                 Array(0, 16), _
                 Array(2, 0), _
                 Array(2, 0))
    
    iNextLine = iStartZeile
    
    Application.ScreenUpdating = False
    
    For Each oFile In oFso.GetFolder(sXlsPath).Files
        If LCase(oFso.GetExtensionName(oFile.Name)) = "xls" Then  
            If ThisWorkbook.Name <> oFile.Name Then
                Set oWkb1 = Workbooks.Open(oFile.Path)
                Set oWks1 = oWkb1.Sheets(1)
                
                'Set Bezugs-Zelle (Bei Zeile 28: A28)  
                Set oNextCell = oWks1.Cells(iStartCopyZeile, "A")  
                
                'Daten kopieren, solange Zelle (B28, B128, ...) mit Inhalt  
                Do While oNextCell.Offset(aOfs(0)(0), aOfs(0)(1)).Text <> ""  
                    For i = 0 To UBound(aOfs)
                        oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = oNextCell.Offset(aOfs(i)(0), aOfs(i)(1)).Value       
                    Next
                    
                    'Set Next Bezugs-Zelle + 100 Zeilen (A128, A228, ...)  
                    Set oNextCell = oNextCell.Offset(iNextCopyZeile, 0):  iNextLine = iNextLine + 1
                Loop
                oWkb1.Close False
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub