XML Dateien importieren um zu vergleichen

Question

Hallo

Ein neues Makro steht wieder an.

Ich will 2 Konfigurationsdateien (= Format.XML) miteinander vergleichen um eventuelle Unterschiede sichtbar zu machen.

Dafür ist es erforderlich dass beide Dateien in einer Arbeitsmappe sind.
Um dies einfach hin zu bekommen habe 2 Arbeitsblätter erzeugt und in "site1" und "site2" umbenannt
- dann beide Dateien in die jeweiligen Arbeitsblätter importiert
- sowie einige überflüssige Kolonnen gelöscht
- Danach wird der gesamte Inhalt z.b. von site2 markiert
- Dann bedingte Formatierung - eigene rule: "=A1<>site1!A1"
- und dann noch bei der Formatierung festgelegt dass Unterschiede GELB markiert werden.

So weit so gut. Von Hand klappt das.
Ich habe folgendes Makro aufgezeichnet.

Sub ELTEK_Compare()
'
' ELTEK_Compare Macro
'
' Keyboard Shortcut: Ctrl+e
'
ActiveWorkbook.XmlImport URL:="E:\Eltek-Trier-10-2015.xml", ImportMap _
:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
Sheets.Add After:=ActiveSheet
ActiveWorkbook.XmlImport URL:="E:\Eltek-Trier-11-12-2015.xml", _
ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "site2"
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "site1"
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Sheets("site2").Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Cells.Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=A1<>site1!A1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A2").Select
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\ti02084\Documents\ELTEK-Compare.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End Sub

-----------------------------------------

Ich mochte nun das Makro etwas anpassen.
Als Ausgangsordner habe ich als c:\ELTEK-Compare festgelegt.
Es soll möglich sein dort eine beliebige XML-Datei anzuwählen.
Sowohl für die erste als auch für die zweite Konfigurationsdatei

Die finale Arbeitsmappe soll auch dort abgespeichert werden.
Dessen Name soll aus dem Namen der als ersten importierten Konfigurationsdatei vorgeschlagen werden.

Hier ist mein Versuch um das Makro anzupassen.
Allerdings stoppt das Ding bereits bei:
ActiveWorkbook.XmlImport Filename:

Es wäre toll wenn jemand mir einen Schupps geben könnte .

Vielen Dank 69

mfg.

Sub ELTEK_Compare()
' Created 06.04.2016
'
' ELTEK_Compare Macro
'
' Keyboard Shortcut: Ctrl+e
'
Dim varName As Variant
Dim strName As String
Dim Neuer_Dateiname As String
Dim strTabname As String
Dim strPfad As String

'Pfad festlegen
strPfad = "C:\ELTEK-Compare\"
'Laufwerk und Pfad zum Öffnen vorgeben
ChDrive "C"
ChDir strPfad

'Datei-Öffnen-Dialog aufrufen
varName = Application.GetImportFilename("XML-Dateien (*.XML),*.xml")

'Letztes \ ermitteln um Pfad und Dateiname zu trennen
strName = Right$(varName, Len(varName) - InStrRev(varName, "\"))

'Letzten . ermitteln um Dateiname und Erweiterung zu trennen
strName = Left(strName, InStrRev(strName, ".") - 1)

ActiveWorkbook.XmlImport Filename:=varName, Origin:=xlWindows, ImportMap _
:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
Sheets.Add After:=ActiveSheet
ActiveWorkbook.XmlImport URL:="C:\ELTEK-Compare\", _
ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "site2"
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "site1"
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Sheets("site2").Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Cells.Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=A1<>site1!A1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A2").Select

'Speichern-unter Dialog aufrufen
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:=strPfad & strName & ".xlsx", fileFilter:="Excel-Arbeitsmappe, *.xlsx")
'falls Abbrechen gedrückt wird, Makro verlassen
If Neuer_Dateiname = "Falsch" Then
'Meldung Makroabbruch
MsgBox "Workbook not saved!", 48, "Abort by user"
Exit Sub
Else
'aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=51
End If
End Sub

Answer 1

Hallo Paul,

schau mal, ob ich das so richtig verstanden habe:

Sub ELTEK_Compare()
' Created 06.04.2016
'
' ELTEK_Compare Macro
'
' Keyboard Shortcut: Ctrl+e
'
Dim varName As Variant
Dim strName As String
Dim Neuer_Dateiname As String
Dim strTabname As String
Dim strPfad As String
Dim strTitel As String
Dim i As Long

'Pfad festlegen
strPfad = "C:\ELTEK-Compare\"
'Laufwerk und Pfad zum Öffnen vorgeben
ChDrive "C"
ChDir strPfad

For i = 1 To 2

strTitel = "Please select the " & i & ". file for import!"

'Datei-Öffnen-Dialog aufrufen
varName = Application.GetOpenFilename("XML-Dateien (*.XML),*.xml", Title:=strTitel)

'Dateinamen der 1. geöffneten Datei in Variable schreiben für Vorschlag speichern
If i = 1 Then
'Letztes \ ermitteln um Pfad und Dateiname zu trennen
strName = Right$(varName, Len(varName) - InStrRev(varName, "\"))

'Letzten . ermitteln um Dateiname und Erweiterung zu trennen
strName = Left(strName, InStrRev(strName, ".") - 1)
End If


With ActiveWorkbook.Worksheets(i)
'Blatt benennen und für Import aktivieren
.Name = "site" & i
.Activate
End With
'Import
ActiveWorkbook.XmlImport URL:=varName, ImportMap _
:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
'Spalten A bis F löschen
ActiveWorkbook.Worksheets(i).Columns("A:F").Delete Shift:=xlToLeft

Next i

'Blatt 2 bedingte Formatierung des genutzten Bereichs
With ActiveWorkbook.Worksheets("site2").UsedRange
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=A1<>site1!A1"
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
.Range("A2").Select
End With

'Speichern-unter Dialog aufrufen
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:=strPfad & strName & ".xlsx", fileFilter:="Excel-Arbeitsmappe, *.xlsx")
'falls Abbrechen gedrückt wird, Makro verlassen
If Neuer_Dateiname = "Falsch" Then
'Meldung Makroabbruch
MsgBox "Workbook not saved!", 48, "Abort by user"
Exit Sub
Else
'aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=51
End If
End Sub

Gruß

M.O.

Answer 2

Hallo M.O.

Danke für deine Antwort.
Welche ich allerdings erst gestern bemerkt habe.
Ich hatte meinen Link versoffen :-)

Der Import der ersten Datei klappt super.
Kolonnen A bis F werden gelöscht.
Das Arbeitsblatt wird auch in site1 umbenannt.
Dann wird man gefragt: "Please select the 2. file for import!"
Wenn ich dann die zweite Datei anwähle kommt eine Fehlermeldung
"Run time error 9"
Der Debugger blinkt bei der ersten Zeile von:
With ActiveWorkbook.Worksheets(i)
'Blatt benennen und für Import aktivieren
.Name = "site" & i
.Activate
End With
Wenn ich dann die markierte Zeile mit der Maus anwähle > erscheint die Meldung
"out of range"





Wünschenswert wäre zudem dass zwar wohl die Dateien in EXCEL importiert werden.
Aber es muss ja nicht unbedingt "meine" Markro.xlms Datei sein.
Momentan wird meine Makro.xlsm z.B. in eine neue Trier.xlsx umbenannt.
Beim Schliessen werde ich dann darauf Aufmerksam gemacht dass xlsx keine Macro's abspeichern kann. Logisch.
Kann man da irgendwo: Open-, oder Import in new Workbook unterbringen ?

Vielen Dank für deinen Tipp

mfg

Answer 3

Hallo Paul,

ich nehme mal an, dass in deiner Datei mit dem Makro nur ein Tabellenblatt vorhanden ist. Wenn die zweite Datei importiert werden soll, kommt es dadurch natürlich zu einem Fehler, da kein zweites Tabellenblatt existiert. Bei deiner Beschreibung bin ich davon ausgegangen, dass in der Arbeitsmappe zwei Tabellenblätter vorhanden sind. Ich habe in das Makro eine entsprechende Prüfung eingebaut, so dass dieser Fehler nicht mehr auftauchen sollte.

Im Prinzip ist es völlig egal, ob du die Dateien in ein neues Workbook importierst, oder das vorhandene Workbook unter neuem Namen als reine .xlsx-Datei speicherst (das Makro brauchst du ja dann nicht mehr). Da dich die Nachfrage offensichtlich stört, habe ich diese ausgeschaltet. Aber Achtung, dadurch werden eventuell vorhandene Dateien ohne Rückfrage überschrieben.

Hier ist das geänderte Makro:

Sub ELTEK_Compare()
' Created 06.04.2016
'
' ELTEK_Compare Macro
'
' Keyboard Shortcut: Ctrl+e
'
Dim varName As Variant
Dim strName As String
Dim Neuer_Dateiname As String
Dim strTabname As String
Dim strPfad As String
Dim strTitel As String
Dim i As Long

'Pfad festlegen
strPfad = "C:\ELTEK-Compare\"
'Laufwerk und Pfad zum Öffnen vorgeben
ChDrive "C"
ChDir strPfad

For i = 1 To 2

strTitel = "Please select the " & i & ". file for import!"

'Datei-Öffnen-Dialog aufrufen
varName = Application.GetOpenFilename("XML-Dateien (*.XML),*.xml", Title:=strTitel)

'Dateinamen der 1. geöffneten Datei in Variable schreiben für Vorschlag speichern
If i = 1 Then
'Letztes \ ermitteln um Pfad und Dateiname zu trennen
strName = Right$(varName, Len(varName) - InStrRev(varName, "\"))

'Letzten . ermitteln um Dateiname und Erweiterung zu trennen
strName = Left(strName, InStrRev(strName, ".") - 1)
End If

'Prüfen ob genug Tabellenblätter in Arbeitsmappe existieren, falls nicht, dann neues Blatt einfügen
If ThisWorkbook.Worksheets.Count > i Then ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)

With ActiveWorkbook.Worksheets(i)
'Blatt benennen und für Import aktivieren
.Name = "site" & i
.Activate
End With
'Import
ActiveWorkbook.XmlImport URL:=varName, ImportMap _
:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
'Spalten A bis F löschen
ActiveWorkbook.Worksheets(i).Columns("A:F").Delete Shift:=xlToLeft

Next i

'Blatt 2 bedingte Formatierung des genutzten Bereichs
With ActiveWorkbook.Worksheets("site2").UsedRange
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=A1<>site1!A1"
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
.Range("A2").Select
End With

'Speichern-unter Dialog aufrufen
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:=strPfad & strName & ".xlsx", fileFilter:="Excel-Arbeitsmappe, *.xlsx")
'falls Abbrechen gedrückt wird, Makro verlassen
If Neuer_Dateiname = "Falsch" Then
'Meldung Makroabbruch
MsgBox "Workbook not saved!", 48, "Abort by user"
Exit Sub
Else
'Benachrichtigungen ausschalten
Application.DisplayAlerts = False
'aktive Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname, FileFormat:=51
'Benachrichtigungen einschalten
Application.DisplayAlerts = True
End If
End Sub

Gruß

M.O.