Liebe Community,

ich hab hier mit Google-Hilfe ein Projekt erstellt, das XML-Dateien in CSV-Dateien umwandeln soll, was soweit auch super funktioniert. Aber: Nicht für eine Datei, sondern für alle Dateien in einem Ordner, wofür ich die Dir-Funktion gefunden habe. Allerdings funktioniert es damit nicht, ich lande immer beim Error.

Die nächste Frage wäre dann noch: Das Projekt würde aus jeder Datei eine eigene CSV-Datei erstellen. Ich brauche aber alle Inhalte in einer einzigen CSV-Datei, untereinander. Wie geht das?

Vielen Dank für jede Hilfe!

Paul

Hier der Code: (irgendwie hab ich das mit der Quellcode-Funktion nicht geschafft)

Option Explicit

Sub XMLinCSV()
    
    Dim LstRw As Long
    Dim c As Integer
    Dim pFlPthSel
    Dim FlNmCSV As String
    Dim FndToC As Range, FndTrnCr As Range
    
pFlPthSel = Dir("C:\Users\Buchhaltung\Desktop\CCD_Converter\Neuer Ordner\*.xml")
Do 'Dein Makro kann nun Datei x öffnen und bearbeiten und wieder schließen
    
    ' Don't update the screen or show alerts
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    ActiveSheet.ScrollArea = "a1"
    ' Go to error message if there's a problems opening the selected XML or XSL
    On Error GoTo NotOpened
    ' Displays the standard Open dialog box and gets a file name from user without actually opening any files.
    ' The XML files in the current folder are displayed
    
    
    'ChDir ActiveWorkbook.Path
    'pFlPthSel = Application.GetOpenFilename("XML Files (*.xml),*.xml", , "Select XML file", , False)
    'pFlPthSel = "C:\Users\Buchhaltung\Desktop\Download-Paket_20241101-20241112 CAMT\test"
    
    ' Open the selected XML file
    Workbooks.OpenXML Filename:=pFlPthSel, Stylesheets:=Array(1)
    On Error GoTo 0
    ' Excel opens the XML file as a formatted CCD in the active worksheet
    With ActiveSheet
        ' Define the row number of the last populated cell
        LstRw = .Range("A65536").End(xlUp).Row
        ' Get rid of all hyperlinks
        .Cells.Hyperlinks.Delete
        ' Delete each blank row
        For c = LstRw To 1 Step -1
            With ActiveSheet.Range("A" & c)
                If Len(.Value) = 0 And .End(xlToRight).Column > 255 Then
                    .EntireRow.Delete
                End If
            End With
        Next c
        ' Find the table of contents row
        Set FndToC = .Range("a2:a" & LstRw).Find("Table of Contents", LookIn:=xlValues, LookAt:=xlWhole)
        If Not FndToC Is Nothing Then
            ' Find the last label in the table of contents ("Transfer of care")
            Set FndTrnCr = .Range("a2:a" & LstRw).Find("Transfer of care", LookIn:=xlValues, LookAt:=xlWhole)
            If Not FndTrnCr Is Nothing Then
                ' Delete the entire table of contents rows
                .Range(FndToC.Address & ":" & FndTrnCr.Address).EntireRow.Delete
            End If
        End If
    End With
    ' Define the name for the newly created file by replacing the "xml" extention with "csv"
    FlNmCSV = Left(pFlPthSel, Len(pFlPthSel) - 3) & "csv"
    ' Save the active workbook as a csv
    ActiveWorkbook.SaveAs Filename:=FlNmCSV, FileFormat:=xlCSV, CreateBackup:=False
    ' Close the active workbook
    ActiveWindow.Close
    ' Display a message showing the path of were it's saved
    
    ' Call MsgBox("A CSV file was just created in " & FlNmCSV, vbInformation, Application.Name)
    
    ' Turn on screen updating and show alerts
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    ' Set variable to nothing
    Set FndToC = Nothing
    Set FndTrnCr = Nothing
    Exit Sub
    ' If there's an error display the following message
NotOpened:
    On Error GoTo 0
    Call MsgBox("The CCD XML file you selected is either corrupt, not a CCD file, or is missing its style sheet." _
                & vbCrLf & "" _
                & vbCrLf & "Make sure the corresponding XSL file is in the same folder as the XML file and try again." _
                , vbCritical, "Error Opening File")
    Application.ScreenUpdating = True
    ' Set variable to nothing
    Set FndToC = Nothing
    Set FndTrnCr = Nothing
    
pFlPthSel = Dir() 'wählt die nächste Datei
Loop Until pFlPthSel = "" 'beendet die Schleife nach der letzten Datei

End Sub