26.03.2019, 09:52
Code:
Public Sub Main()
with Workbooks.OpenXML("C:\Temp\XML_Document1.xml")
.sheets(1).Range("K3,L3,R3").Copy Tabelle1.Range("A1")
.Close 0
end with
End Sub
Public Sub Main()
with Workbooks.OpenXML("C:\Temp\XML_Document1.xml")
.sheets(1).Range("K3,L3,R3").Copy Tabelle1.Range("A1")
.Close 0
end with
End Sub
Sub Read_XML()
'URL in Spalte A
With CreateObject("MSXML2.DOMDocument")
For i = Cells(Rows.Count, "B").End(xlUp).Row + 1 To Cells(Rows.Count, "A").End(xlUp).Row
.Load Cells(i, 1).Text
sp = 2
For e = 0 To .getElementsByTagName("jobkey").Length - 1
Cells(i, sp).Offset(, 0) = .getElementsByTagName("jobkey")(e).Text
Cells(i, sp).Offset(, 1) = .getElementsByTagName("jobtitle")(e).Text
Cells(i, sp).Offset(, 2) = .getElementsByTagName("url")(e).Text
sp = sp + 3
Next e
Next i
End With
End Sub
Sub AlleXMLsAbrufen()
Dim urlTabelle As String
Dim ergebnisTabelle As String
Dim zeileURLs As String
Dim url As String
Dim aktuelleZeile As Long
Dim aktuelleSpalteEins As Integer
Dim anzahlDatensaetze As Long
urlTabelle = "URLs"
ergebnisTabelle = "Eingelesene Daten"
anzahlDatensaetze = 10 'optional, wenn weggelassen, werden alle eingelesen
zeileURLs = 2 'Startzeile der abzuarbeitenden URLs
'Alle URLs in URL-Tabelle durchgehen
Do Until Sheets(urlTabelle).Cells(zeileURLs, 1).Value = ""
aktuelleZeile = 2
If Sheets(ergebnisTabelle).Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
aktuelleSpalteEins = Sheets(ergebnisTabelle).UsedRange.Columns.Count
Else
aktuelleSpalteEins = Sheets(ergebnisTabelle).UsedRange.Columns.Count + 1
End If
url = Sheets(urlTabelle).Cells(zeileURLs, 1).Value
Call EineXMLEinlesen(url, ergebnisTabelle, aktuelleZeile, aktuelleSpalteEins, anzahlDatensaetze)
zeileURLs = zeileURLs + 1
Loop
End Sub
Sub EineXMLEinlesen(url As String, tabelle As String, aktuelleZeile As Long, aktuelleSpalteEins As Integer, Optional anzahlDatensaetze As Long = 0)
'Variablen für den Dateizugriff und das DOM-Handling
Dim xmlDocument As Object
Dim knotenResult As Object
Dim knotenResultEinzel As Object
Dim knotenJobkey As Object
Dim knotenJobtitle As Object
Dim knotenURL As Object
Dim aktuellerDatensatz As Long
'XML-Dokument instanzieren und XML-Dokument einlesen
Set xmlDocument = CreateObject("MSXML2.DOMDocument")
xmlDocument.Load url
'Result-Tags einsammeln
Set knotenResult = xmlDocument.getElementsByTagName("result")
If Not knotenResult Is Nothing Then
'Wenn vorhanden gewünschte Anzahl Result-Tags durchgehen
For Each knotenResultEinzel In knotenResult
'Datensätze hochzählen
aktuellerDatensatz = aktuellerDatensatz + 1
'Gewünschte Werte holen
Set knotenJobkey = knotenResultEinzel.getElementsByTagName("jobkey")(0)
Set knotenJobtitle = knotenResultEinzel.getElementsByTagName("jobtitle")(0)
Set knotenURL = knotenResultEinzel.getElementsByTagName("url")(0)
'Gewünschte Werte in die Tabelle eintragen, aus der das Makro gestartet wurde
'(feste Tabelle kann natürlich vorangestellt werden)
Sheets(tabelle).Cells(aktuelleZeile, aktuelleSpalteEins).Value = knotenJobkey.Text
Sheets(tabelle).Cells(aktuelleZeile, aktuelleSpalteEins + 1).Value = knotenJobtitle.Text
Sheets(tabelle).Cells(aktuelleZeile, aktuelleSpalteEins + 2).Value = knotenURL.Text
'Nächste Zeile zum Beschreiben festlegen
aktuelleZeile = aktuelleZeile + 1
'Prüfen ob gewünschte Anzahl Datensätze eingelesen wurde, wenn
'maximale Anzahl vorgegeben wurde und Einlesen ggf. beenden
If aktuellerDatensatz = anzahlDatensaetze Then
Exit For
End If
Next knotenResultEinzel
End If
'Aufräumen
Set xmlDocument = Nothing
Set knotenResult = Nothing
Set knotenResultEinzel = Nothing
Set knotenJobkey = Nothing
Set knotenJobtitle = Nothing
Set knotenURL = Nothing
End Sub
Sub M_snb()
sn = Sheet1.Columns(1).SpecialCells(2)
With CreateObject("MSXML2.DOMDocument")
For j = 1 To UBound(sn)
.Load sn(j, 1)
ReDim sp(UBound(sn), .getElementsByTagName("jobkey").Length - 1)
For jj = 0 To UBound(sp, 2) Step 3
sp(j, jj) = .getElementsByTagName("jobkey")(jj).Text
sp(j, jj + 1) = .getElementsByTagName("jobtitle")(jj).Text
sp(j, jj + 2) = .getElementsByTagName("url")(jj).Text
Next
Next
End With
Sheet1.Cells(1, 2).resize(UBound(sp), UBound(sp, 2) + 1) = sp
End Sub