|
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
|