Sprach- und literaturwissenschaftliche Fakultät - Korpuslinguistik und Morphologie


 

' VBA-Script zum Splitten zusammengeführter Excel-Dateien anhand der Marker <NEW_DOCUMENT: ...> - einfach Datei in Excel öffnen und folgendes VBA-Script ausführen

Option Explicit

Sub SplitMergedByMarkers()
    Dim ws As Worksheet
    Dim wbOut As Workbook
    Dim wsOut As Worksheet
    Dim lastRow As Long
    Dim r As Long, j As Long, nextMarker As Long
    Dim savePath As String
    Dim cellVal As String
    Dim fileBase As String
    Dim markerRows As Collection
    Dim k As Long
    Dim fullName As String
    
    Set ws = ThisWorkbook.Worksheets(1) ' arbeitet nur auf dem ersten Blatt
    savePath = ThisWorkbook.Path & "\"
    
    Set markerRows = New Collection
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    r = 1
    Do While r <= lastRow
        cellVal = Trim(CStr(ws.Cells(r, 1).Value))
        
        ' Marker erkennen, Groß/Kleinschreibung egal
        If LCase(Left(cellVal, 14)) = LCase("<new_document:") Then
            markerRows.Add r
            
            ' Dateiname extrahieren (zwischen ":" und ">")
            fileBase = Mid(cellVal, 15)          ' alles nach "<NEW_DOCUMENT:"
            If Right(fileBase, 1) = ">" Then
                fileBase = Left(fileBase, Len(fileBase) - 1)
            End If
            fileBase = Trim(fileBase)
            
            ' nächste Marker-Zeile oder Ende finden
            nextMarker = lastRow
            For j = r + 1 To lastRow
                If LCase(Left(Trim(CStr(ws.Cells(j, 1).Value)), 14)) = LCase("<new_document:") Then
                    nextMarker = j - 1
                    Exit For
                End If
            Next j
            
            ' neue Arbeitsmappe erzeugen und Inhalte kopieren
            Set wbOut = Workbooks.Add(xlWBATWorksheet)
            Set wsOut = wbOut.Worksheets(1)
            
            If nextMarker >= r + 1 Then
                ws.Rows((r + 1) & ":" & nextMarker).Copy Destination:=wsOut.Range("A1")
            End If
            
            ' speichern und schließen
            fullName = savePath & fileBase & ".xlsx"
            wbOut.SaveAs Filename:=fullName, FileFormat:=xlOpenXMLWorkbook
            wbOut.Close SaveChanges:=False
            
            r = nextMarker + 1
        Else
            r = r + 1
        End If
    Loop
    
    ' Marker-Zeilen löschen (von unten nach oben)
    If markerRows.Count > 0 Then
        For k = markerRows.Count To 1 Step -1
            ws.Rows(markerRows(k)).Delete
        Next k
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox "Fertig. " & markerRows.Count & " Dateien erzeugt und Markerzeilen entfernt.", vbInformation
End Sub