AW: Alle HTML Dateien aus Verzeichnis einlesen
18.10.2018 13:00:42
UweD
Hallo
da der Dateiname ja scheinbar schon die 13 oder 12 etc. ist, kann der name direkt verwendet werden.
Abgeschnitten wird das .htm.
3 Änderungen im Code
Modul1
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 ext As String
Dim datei As String
Dim datum As Date
Dim dateiName As String
pfad = "C:\temp\" ' keine/
pfad = "x:\temp\test\" ' keine/
ext = ".htm"
datei = Dir(pfad & "*" & ext)
zeile = 5
Do While Len(datei) > 0
url = "file:///" & Replace(pfad, "\", "/") & datei
datum = Format(GetFileDate(pfad & datei), "dd.MM.yyyy")
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
For Each knotenZweig In knotenAst
If InStr(1, knotenZweig.innertext, "|") > 0 Then
Cells(zeile, 1).Value = datum
Cells(zeile, 2).Value = "Lager" & Replace(datei, ext, "")
splitArray = Split(knotenZweig.innertext, "|")
For i = 0 To Ubound(splitArray)
Select Case i
Case 2
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 3).Value = Trim(splitArray(i))
Case 3
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 4).Value = Trim(splitArray(i))
Case 6
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 5).Value = Trim(splitArray(i))
Case 8
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 6).Value = Trim(splitArray(i))
Case 12
splitArray(i) = Replace(splitArray(i), Chr(160), "")
Cells(zeile, 8).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
datei = Dir() ' nächste Datei
Loop
browser.Quit
Set browser = Nothing
Set knotenAst = Nothing
Set knotenZweig = Nothing
End Sub
Function GetFileDate(ByVal sFilePath As String) As Date
Dim fso As Object
Dim fsFile As Object
Dim dReturn As Date
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(sFilePath) Then
Set fsFile = fso.GetFile(sFilePath)
dReturn = fsFile.DateCreated
Else
dReturn = CDate("01.01.1900")
End If
GetFileDate = dReturn
End Function
LG UweD