AW: Wer hat denn den HTML Aufbau verbrochen?
12.06.2018 10:45:26
Zwenn
Hallo zusammen,
ich würde es so machen:
Sub DatenAusHTML()
Dim browser As Object
Dim url As String
Dim knotenAst As Object
Dim knotenZweig As Object
Dim splitArray() As String
Dim i As Long
Dim zeile As Long
Dim pfad As String
Dim tabName As String
'Für URL den Pfad zu Deiner HTML Datei setzen!
pfad = "E:/Rest/Herber Forum/Werte aus HTML Datei holen - Patrick/122045.html"
url = "file:///" & pfad
zeile = 2
tabName = Format(GetFileDate(pfad), "dd.MM.yyyy")
If tabName "01.01.1900" Then
If WorksheetEx(tabName) = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = tabName
Else
MsgBox "Ein Tabellenbaltt mit diesem Namen existiert bereits."
Exit Sub
End If
Else
MsgBox "Die angegebene Datei existiert nicht." & Chr(13) & _
Chr(13) & "Mögliche Fehlerquelle 1:" & Chr(13) & _
"Der Pfad enthält Leerzeichen, die durch das Kopieren " & _
"der URL aus dem Browser durch %20 ersetzt wurden." & _
"Lösung: Jedes %20 durch ein Leerzeichen ersetzen." & Chr(13) & _
Chr(13) & "Mögliche Fehlerquelle 2:" & Chr(13) & _
"Dem Pfad ist file:/// vorangestellt. " & _
"Diese Zeichenkette ist nur für die URL wichtig " & _
"und wird automatisch ergänzt." & _
Chr(13) & Chr(13) & "Lösung:" & Chr(13) & _
"Den Präfix file:/// aus dem Pfad löschen"
Exit Sub
End If
Set browser = CreateObject("internetexplorer.application")
browser.Visible = False
browser.navigate url
Do Until browser.readyState = 4: DoEvents: Loop
Set knotenAst = browser.document.getElementsByTagName("span")
If Not knotenAst Is Nothing Then
'Kopfzeile
Cells(1, 1).Value = "Materialnummer"
Cells(1, 2).Value = "Materialkurztext"
Cells(1, 3).Value = "Bestand SAP"
Cells(1, 4).Value = "Me(SAP)"
Cells(1, 5).Value = "Bestand WMS"
Cells(1, 6).Value = "Me(WMS)"
Cells(1, 7).Value = "Bestandsdifferenz"
For Each knotenZweig In knotenAst
If InStr(1, knotenZweig.innertext, "|") > 0 Then
splitArray = Split(knotenZweig.innertext, "|")
For i = 0 To UBound(splitArray)
Select Case i
Case 2
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 1).Value = Trim(splitArray(i))
Case 3
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 2).Value = Trim(splitArray(i))
Case 6
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 3).Value = Trim(splitArray(i))
Case 7
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 4).Value = Trim(splitArray(i))
Case 8
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 5).Value = Trim(splitArray(i))
Case 9
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 6).Value = Trim(splitArray(i))
Case 10
splitArray(i) = Replace(splitArray(i), Chr(160), " ")
Cells(zeile, 7).Value = Trim(splitArray(i))
End Select
Next i
zeile = zeile + 1
End If
Next knotenZweig
End If
browser.Quit
Set browser = Nothing
Set knotenAst = Nothing
Set knotenZweig = Nothing
End Sub
Function GetFileDate(ByVal sFilePath As String) As Date
'Quelle: http://www.office- _
loesung.de/ftopic182822_0_0_asc.php
Dim fso As Object
Dim fsFile As Object
Dim dReturn As Date
Set fso = CreateObject("Scripting.FileSystemObject")
'Existiert die Datei?
If fso.FileExists(sFilePath) Then
Set fsFile = fso.GetFile(sFilePath)
dReturn = fsFile.DateLastModified ' - Letzte Änderung
'Alternativen:
'dReturn = fsFile.DateLastAccessed ' - Letzter Zugriff
'dReturn = fsFile.DateCreated ' - Erstelldatum
Else
'Irgendein Rückgabedatum für den Elsefall wählen, um diesen nachher abzufangen
dReturn = CDate("01.01.1900")
End If
GetFileDate = dReturn
End Function
Function WorksheetEx(strNam As String) As Boolean
'Quelle: https://www.herber.de/forum/archiv/1088to1092/1088944_Ueberpruefen_ob_Tabellenblatt_existiert.html
On Error Resume Next
WorksheetEx = Worksheets(strNam).Index > 0
End Function
Viele Grüße,
Zwenn