(Fast) gleichartige XML-Dateien auswerten

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: (Fast) gleichartige XML-Dateien auswerten
von: Rainer Hitzemann
Geschrieben am: 14.08.2015 15:42:31

Hallo VB-Gurus!
Ich habe zwar die SuFu schon umfangreich genutzt, aber ich tue mich schwer, die zahlreichen Beiträge an meine Fragestellung anzupassen. Daher meine Bitte um Unterstützung:
ich habe in mehreren Unterordnern XML-Dateien, die _fast_ gleichartig aufgebaut sind und durchsucht werden sollen. Der Unterschied ist, dass manche XML-Dateien den zusätzlichen Abschnitt "migrationsTabelle" aufweisen; die restlichen nicht:
Userbild
Aus diesem Abschnitt benötige ich in einer Excel-Tabelle die Werte für und .
Ist der Abschnitt nicht vorhanden, soll im Arbeitsblatt stattdessen "n/a" (not available) eingetragen werden.
Ich hoffe, ich habe es verständlich ausgedrückt. Vielen Dank schon mal im voraus!
Grüße, Rainer

Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: Sepp
Geschrieben am: 15.08.2015 01:46:01
Hallo Raier,
was soll
"Aus diesem Abschnitt benötige ich in einer Excel-Tabelle die Werte für und ."
bedeuten?

Gruß Sepp


Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: superhit
Geschrieben am: 15.08.2015 17:31:04
Hallo Sepp,
pardon, da ist etwas verlorengegangen. Gemeint war: "ich benötige in einer Excel-Tabelle die Werte für 'snapshotStatus' und 'status'".
Grüße, Rainer

Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: Sepp
Geschrieben am: 15.08.2015 18:03:13
Hallo Rainer,
probier mal.
https://www.herber.de/bbs/user/99600.xlsm

Gruß Sepp


Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: superhit
Geschrieben am: 15.08.2015 22:22:17
Hallo Sepp,
vielen Dank! Sobald ich zum Testen gekommen bin (kann Montag werden), gebe ich Rückmeldung.
Grüße, Rainer

Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: superhit
Geschrieben am: 16.08.2015 12:55:05
Hallo Sepp,
ganz funktioniert das Makro leider noch nicht. Hier das Ergebnis mit einer Testdatei (die den Abschnitt "migrationsTabelle" enthält) als Screenshot:
Userbild
Die gezippte Testdatei hänge ich ebenfalls mal an:
https://www.herber.de/bbs/user/99618.zip
Viele Grüße,
Rainer

Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: Sepp
Geschrieben am: 16.08.2015 13:10:11
Hallo Rainer,
bei deinem Screenshot hatte die xml Zeilenümbrüche!
ersetze den Code durch diesen.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub getDataXML()
Dim objFiles() As Object
Dim strPath As String, strTmp As String, strA As String, strB As String
Dim strF1 As String, strF2 As String
Dim lngI As Long, lngRet As Long, lngR As Long
Dim FF As Integer

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\" 'Startverzeichnis - Anpassen!
  .Title = "XML Import Ordnerauswahl"
  .ButtonName = "Import Starten"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  lngRet = FileSearchFSO(objFiles, strPath, "*.xml", True)
  If lngRet > 0 Then
    strF1 = "snapshotStatus>"
    strF2 = "status>"
    lngR = 2
    With Sheets("Tabelle1") 'Ausgabetabelle - Anpassen!
      .Range("A2:C" & .Rows.Count).ClearContents
      For lngI = 0 To lngRet - 1
        strA = "n/a": strB = "n/a"
        .Cells(lngR, 1) = objFiles(lngI).Path
        FF = FreeFile
        Open objFiles(lngI).Path For Input As #FF
        Do While Not EOF(FF)
          Line Input #FF, strTmp
          If InStr(1, strTmp, strF1) > 0 Then
            strA = Mid(strTmp, InStr(1, strTmp, strF1) + Len(strF1), InStr(1, strTmp, "</" & strF1) _
              - (InStr(1, strTmp, strF1) + Len(strF1)))
          End If
          If InStr(1, strTmp, strF2) > 0 Then
            strB = Mid(strTmp, InStr(1, strTmp, strF2) + Len(strF2), InStr(1, strTmp, "</" & strF2) _
              - (InStr(1, strTmp, strF2) + Len(strF2)))
          End If
        Loop
        Close #FF
        .Cells(lngR, 2) = strA
        .Cells(lngR, 3) = strB
        lngR = lngR + 1
      Next
    End With
  End If
End If

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'getDataXML'" & vbLf & String(60, "_") & vbLf & vbLf & _
      IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
      .Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
      vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - getDataXML"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub


Private Function FileSearchFSO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
  Optional ByVal SubFolders As Boolean = False) As Long




'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Dim intC As Integer, varFiles As Variant

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
  varFiles = Split(FileName, ";")
Else
  Redim varFiles(0)
  varFiles(0) = FileName
End If

For Each mfsoFile In mfsoFolder.Files
  If Not mfsoFile Is Nothing Then
    For intC = 0 To UBound(varFiles)
      If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(varFiles(intC)) Then
        If IsArray(Files) Then
          Redim Preserve Files(UBound(Files) + 1)
        Else
          Redim Files(0)
        End If
        Set Files(UBound(Files)) = mfsoFile
        Exit For
      End If
    Next
  End If
Next

If SubFolders Then
  For Each mfsoSubFolder In mfsoFolder.SubFolders
    FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
  Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
ErrExit:
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function


Gruß Sepp


Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: superhit
Geschrieben am: 16.08.2015 14:03:31
Hallo Sepp,
ganz herzlichen Dank! Jetzt klappt das Einlesen perfekt. Hast du das Makro "mal eben on the fly" erstellt, nachdem ich die fehlenden Angaben ergänzt hatte? Wenn ja, kann ich nur sagen: Chapeau!
Grüße, Rainer

Bild

Betrifft: AW: (Fast) gleichartige XML-Dateien auswerten
von: Sepp
Geschrieben am: 16.08.2015 14:12:15
Hallo Rainer,
freut mich, dass es klappt.
on the fly, na ja, String-Operationen sind ja nicht wirklich schwer, wenn man weiß was man wo suchen und herausfiltern muss.

Gruß Sepp


 Bild

Beiträge aus den Excel-Beispielen zum Thema "(Fast) gleichartige XML-Dateien auswerten"