Da dieser Code uralt ist und größtenteills nicht von dir stammt, verstehst du ihn möglicherweise nicht gänzlich.
bei welchem Error landest du? Es gibt ne ganze Menge. Dieser Code wurde für ccd Dateien geschrieben. Verwendest du ihn auch dafür? Hast du die Schleife eingebaut oder eine KI? Der Code öffnet eine Xml datei in Excel: löscht leere Zeilen und einen Bereich in der Xmldatei. Die selbe Datei wir dann als csv gespeichert.
Du willst aber etwas ganz Anderes. Und hier beginnt das Problem. Denn der Code müßte die erste Datei öffnen, den Bereich löschen, und entweder den Rest in eine neuen Datei kopieren oder die erste Datei dazu zu nutzen, um die Inhalte der folgenden Dateien dort hinein zu kopieren und dann diese erste Datei als Csv zu speichern.
Hier mein Versuch, aber ungetestet. Wenns nicht funktioniert, Pech gehabt. Ohne die passenden Dateien ist das nur ein Ratespiel.
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
Dim firstWB As Workbook
Dim aktualWB As Workbook
' 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"
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
if pFlPthSel = "" then exit sub 'Abbruch wenn nichts gefunden
' Open the selected XML file
If firstWB Is Nothing Then
Set firstWB = Workbooks.OpenXML(Filename:=pFlPthSel, Stylesheets:=Array(1))
Else
Set aktualWB = Workbooks.OpenXML(Filename:=pFlPthSel, Stylesheets:=Array(1))
End If
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 = .Cells(.Rows.Count, 1).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
If ActiveWorkbook = aktualWB Then
'usedrange in firstwb kopieren
ActiveSheet.UsedRange.Copy firstWB.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Offset(1)
aktualWB.Close savechanges:=False
End If
pFlPthSel = Dir() 'wählt die nächste Datei
Loop Until pFlPthSel = "" 'beendet die Schleife nach der letzten Datei
' 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
firstWB.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
End Sub
|