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
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ActiveSheet.ScrollArea = "a1"
On Error GoTo NotOpened
pFlPthSel = Dir("C:\Users\Buchhaltung\Desktop\CCD_Converter\Neuer Ordner\*.xml")
Do
if pFlPthSel = "" then exit sub
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
With ActiveSheet
LstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells.Hyperlinks.Delete
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
Set FndToC = .Range("a2:a" & LstRw).Find("Table of Contents", LookIn:=xlValues, LookAt:=xlWhole)
If Not FndToC Is Nothing Then
Set FndTrnCr = .Range("a2:a" & LstRw).Find("Transfer of care", LookIn:=xlValues, LookAt:=xlWhole)
If Not FndTrnCr Is Nothing Then
.Range(FndToC.Address & ":" & FndTrnCr.Address).EntireRow.Delete
End If
End If
End With
If ActiveWorkbook = aktualWB Then
ActiveSheet.UsedRange.Copy firstWB.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Offset(1)
aktualWB.Close savechanges:=False
End If
pFlPthSel = Dir()
Loop Until pFlPthSel = ""
FlNmCSV = Left(pFlPthSel, Len(pFlPthSel) - 3) & "csv"
firstWB.SaveAs Filename:=FlNmCSV, FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set FndToC = Nothing
Set FndTrnCr = Nothing
Exit Sub
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 FndToC = Nothing
Set FndTrnCr = Nothing
End Sub