AW: Fehler in VBA Dir-Funktion?
18.11.2024 15:47:09
volti
Hallo Paul,
Deine Aussage, dass alles schon ganz gut funktioniert, kann ich nicht nachvollziehen.
Die bereitgestellte XML-Datei kann bei mir mit dem Codebeispiel nicht geöffnet werden. Es öffnet nur, wenn ich Stylesheets:=Array(1) weglasse.
Der Code entfernt Leerzielen; es gibt aber gar keine Leerzeilen in der Datei.
Der Code sucht zwei Suchbegriffe und macht dann was. Die Suchbegriffe sind aber gar nicht in der Datei vorhanden.
Ich kenne mich mit XML-Datei nicht aus.
Wenn Du aber nur den von Excel erzeugten Inhalt je Datei in eine Ausgangsdatei schreiben möchtest, habe ich hier mal eine Idee.
Zu Fuß per VBA in eine CSV-Datei schreiben wie schon vor 30 Jahren. :-)
Ginge natürlich auch moderner, würde manch anderer schreiben. Aber der kann sich dann ja melden. :-)
PS: Wenn der Mittelteil wegfallen kann, kann auch Screenupdating und DisplayAlerts entfallen, denn mit dieser Schreibmethode wird ja nichts an der Tabelle verändert und es kommt zu keinerlei Verzögerungen
Code:
Option Explicit
Sub XMLinCSV()
Dim iZeile As Long, iZl As Long, iSP As Long
Dim sDatei As String, sPfad As String, sDateiCSV As String
Dim DS As String
Dim oRngBgn As Range, oRngEnd As Range, WKb As Workbook
' sPfad = "C:\Users\Buchhaltung\Desktop\Download-Paket_20241101-20241112 CAMT\test\ "
sPfad = ThisWorkbook.Path & "\"
sDateiCSV = sPfad & "Zieldatei.csv"
If Dir$(sDateiCSV) <> "" Then Kill sDateiCSV ' Alte Ausgabedatei löschen
sDatei = Dir(sPfad & "*.xml")
If sDatei = "" Then Exit Sub ' Keine XML-Dateien gefunden
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Open sDateiCSV For Append As #1
Do
On Error Resume Next
Set WKb = Workbooks.OpenXML(Filename:=sPfad & sDatei) ', Stylesheets:=Array(1))
If WKb Is Nothing Then
MsgBox "Die Datei '" & sDateiCSV & "' konnte nicht geöffnet werden!", vbCritical
Else
With ActiveSheet
iZeile = .Range("A65536").End(xlUp).Row ' Letzte belegte Zeile
.Cells.Hyperlinks.Delete ' Hyperlinks entfernen
For iZl = iZeile To 1 Step -1 ' Leere Zeile entfernen
With .Range("A" & iZl)
If Len(.Value) = 0 And .End(xlToRight).Column > 255 Then
.EntireRow.Delete
End If
End With
Next iZl
' Finde die Tabelle mit Inhalt
Set oRngBgn = .Range("a2:a" & iZeile).Find("Table of Contents", _
LookIn:=xlValues, LookAt:=xlWhole)
If Not oRngBgn Is Nothing Then
' Find the last label in the table of contents ("Transfer of care")
Set oRngEnd = .Range("a2:a" & iZeile).Find("Transfer of care", _
LookIn:=xlValues, LookAt:=xlWhole)
If Not oRngEnd Is Nothing Then
' Delete the entire table of contents rows
.Range(oRngBgn.Address & ":" & oRngEnd.Address).EntireRow.Delete
End If
End If
' Daten ausgeben in Zieldatei, nur wenn welche gefunden
For iZl = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row ' Letzte Zeile in Spalte
DS = ""
For iSP = 1 To .Cells(iZl, Columns.Count).End(xlToLeft).Column
DS = DS & .Cells(iZl, iSP) & ";"
Next iSP
Print #1, Left$(DS, Len(DS) - 1) ' Datensatz schreiben
Next iZl
ActiveWindow.Close ' XML-Datei schließen
End With
End If
sDatei = Dir ' wählt die nächste Datei
Loop Until sDatei = "" ' beendet die Schleife
Close #1 ' Zieldatei schließen
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Die CSV-Datei " & sDateiCSV & " wurde erstellt!", vbInformation
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz