Exceldateien per Makro zusammenführen

Option Explicit
Sub Collect()

'zu bearbeitende Quell-Dateien  
Const sQuellPfad As String = "D:\ADM\" '###  
Const sKennzeichen As String = "_PSB_" '###  

'Quelldaten  
'Stammdaten  
Const sStamm As String = "E4:E5,E7:E10,E12:E13,E15:E19,O15:O16,K19" '###  
Const sBesonderheiten As String = "B54:B56" '###  
Const sDelim As String = " | " '### Trennzeichen bei mehreren Besonderheiten  

'Quell-Datenzeilen  
Dim iDatenZeile(3, 4) As Integer
Dim iDatenBlockAnzahl As Integer, iDatenZeilenAnzahl As Integer

iDatenZeile(1, 0) = 23 '###  
iDatenZeile(1, 1) = 24 '###  
iDatenZeile(1, 2) = 25 '###  
iDatenZeile(1, 3) = 28 '###  
iDatenZeile(1, 4) = 31 '###  

iDatenZeile(2, 0) = 33 '###  
iDatenZeile(2, 1) = 34 '###  
iDatenZeile(2, 2) = 35 '###  
iDatenZeile(2, 3) = 38 '###  
iDatenZeile(2, 4) = 41 '###  

iDatenZeile(3, 0) = 43 '###  
iDatenZeile(3, 1) = 44 '###  
iDatenZeile(3, 2) = 45 '###  
iDatenZeile(3, 3) = 48 '###  
iDatenZeile(3, 4) = 51 '###  

iDatenBlockAnzahl = UBound(iDatenZeile, 1)
iDatenZeilenAnzahl = UBound(iDatenZeile, 2)

'Quell-Datenspalten  
Const iDatenMinSpalte As Integer = 3 '### ab Spalte C  
Const iDatenMaxSpalte As Integer = 15 '### bis Spalte O  

Dim iDatenSpaltenAnzahl As Integer
iDatenSpaltenAnzahl = (iDatenMaxSpalte - iDatenMinSpalte) / 2 + 1

'Zieldatei  
Dim oZielBlatt As Object
Set oZielBlatt = ThisWorkbook.Worksheets("Tabelle1") '### Blattnamen festlegen  

'Zieldaten  
Const iStartSpalte As Integer = 1 '### ab Spalte A  
Dim iZeile As Integer
iZeile = 2 '### Erste mögliche Datenzeile der Zieldatei  

'################################################################  

Dim fso As Object
Dim oQuellDatei As Object, sQuellDatei As String
Dim iQuellDateienAnzahl As Integer
iQuellDateienAnzahl = 0

Dim oQuellBlatt As Object

Dim rStammWerte As Object, oStammWert As Object
Dim oBesonderheit As Object, sBesonderheit As String

Dim iSpalte As Integer
Dim iBlock As Integer, z As Integer, s As Integer

'Zeile für erste Eintragung bestimmen  
Do While oZielBlatt.Cells(iZeile, iStartSpalte).Value <> ""  
    iZeile = iZeile + 1
Loop

Set fso = CreateObject("Scripting.FileSystemObject")  
For Each oQuellDatei In fso.GetFolder(sQuellPfad).Files
    sQuellDatei = oQuellDatei.Name
    If InStr(sQuellDatei, sKennzeichen) Then 'Kennzeichen im Dateinamen enthalten?  
        Workbooks.Open oQuellDatei.Path
        iQuellDateienAnzahl = iQuellDateienAnzahl + 1
        
        'Stammdaten lesen (inkl. Zusammenfassung Besonderheiten)  
        Set oQuellBlatt = Workbooks(sQuellDatei).Worksheets(1)
        Set rStammWerte = oQuellBlatt.Range(sStamm).Cells
        
        sBesonderheit = ""  
        For Each oBesonderheit In oQuellBlatt.Range(sBesonderheiten).Cells
            If oBesonderheit.Value <> "" Then  
                If sBesonderheit = "" Then  
                    sBesonderheit = oBesonderheit.Value
                Else
                    sBesonderheit = sBesonderheit & sDelim & oBesonderheit.Value
                End If
            End If
        Next
        
        'Alle Datenzeilen durchsuchen  
        For iBlock = 1 To iDatenBlockAnzahl
            For s = 1 To iDatenSpaltenAnzahl
                For z = 1 To iDatenZeilenAnzahl
                
                    'Falls Eintrag vorhanden, Zeile in Zieltabelle erzeugen  
                    If oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 2) <> "" Then  
                    
                        'Stammdaten eintragen  
                        iSpalte = iStartSpalte
                        For Each oStammWert In rStammWerte.Cells
                            With oZielBlatt.Cells(iZeile, iSpalte)
                                .Value = oStammWert.Value
                                .NumberFormat = oStammWert.NumberFormat
                                .HorizontalAlignment = oStammWert.HorizontalAlignment
                            End With
                            iSpalte = iSpalte + 1
                        Next
                        oZielBlatt.Cells(iZeile, iSpalte).Value = sBesonderheit
                        
                        'Daten und ausgewählte Formate übernehmen  
                        With oZielBlatt.Cells(iZeile, iSpalte + z * 2 - 2)
                            .Value = oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 2).Value
                            .NumberFormat = oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 2).NumberFormat
                            .HorizontalAlignment = oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 2).HorizontalAlignment
                        End With
                        With oZielBlatt.Cells(iZeile, iSpalte + z * 2 - 1)
                            .Value = oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 1).Value
                            .NumberFormat = oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 2).NumberFormat
                            .HorizontalAlignment = oQuellBlatt.Cells(iDatenZeile(iBlock, z), iDatenMinSpalte + s * 2 - 2).HorizontalAlignment
                        End With
                        With oZielBlatt.Cells(iZeile, iSpalte + iDatenZeilenAnzahl * 2)
                            .Value = oQuellBlatt.Cells(iDatenZeile(iBlock, 0), iDatenMinSpalte + s * 2 - 2).Value
                            .NumberFormat = oQuellBlatt.Cells(iDatenZeile(iBlock, 0), iDatenMinSpalte + s * 2 - 2).NumberFormat
                            .HorizontalAlignment = oQuellBlatt.Cells(iDatenZeile(iBlock, 0), iDatenMinSpalte + s * 2 - 2).HorizontalAlignment
                        End With
                        
                        iZeile = iZeile + 1 'Zeilennummer für nächste Zeile der Zieltabelle  
                        
                    End If
                Next 'z  
            Next 's  
        Next 'iBlock  
        Workbooks(sQuellDatei).Close SaveChanges:=False
        
    End If
Next 'oQuellDatei  

MsgBox iQuellDateienAnzahl & " Dateien bearbeitet."  
End Sub

oZielBlatt.Cells(iZeile, iSpalte).Value = sBesonderheit

oZielBlatt.Cells(iZeile, iSpalte + iDatenZeilenAnzahl * 2 + 1).Value = sBesonderheit