HTML - Enumerating - Format!

Two possibilities to convert "HTML files" in "XLS files". Either with "QueryTables", or into that "HTML files" each enumerating an inverted comma is placed in front. The problem is the enumerating - for example 1.1, 1.2.4 etc. This is interpreted in Excel as date. The files at the end of the article are Excelfiles of the version 2003 and 2007 with example files in the Zipformat. The following code belonged in "Module1"


Zwei Möglichkeiten, wie "HTML-Dateien" in "XLS-Dateien" umgewandelt werden können. Entweder über die "QueryTables", oder in den "HTML-Dateien" wird den Aufzählungen ein Hochkomma vorangestellt. Die Problematik liegt in den Aufzählungen - zum Beispiel 1.1, 1.2.4 usw. Dies wird in Excel als Datum interpretiert. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007 mit Beispieldateien im Zipformat. Der folgende Code gehört in "Modul1"


Option Explicit
Public Sub Save_HTML_XLS_Query()
Dim qtTableResult As QueryTable
Dim strFileName As String
Dim wksSheet As Worksheet
Dim wkbBook As Workbook
Dim strWbName As String
Dim objShell As Object
Dim intTMP As Integer
Dim strPath As String
Dim varDir As Variant
Dim lngRow As Long
On Error GoTo Fin
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Ordner", &H1000, 17)
If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
strPath = varDir.Self.Path
If strPath <> "" Then
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strFileName = Dir(strPath)
If strFileName <> "" Then
Do While strFileName <> ""
If strFileName Like "*.ht*" Then
intTMP = intTMP + 1
Set wkbBook = Workbooks.Add(xlWBATWorksheet)
Set wksSheet = wkbBook.Worksheets(1)
Set qtTableResult = wksSheet.QueryTables _
.Add(Connection:="URL;file://" & _
strPath & strFileName, _
Destination:=wksSheet.Cells(1, 1))
With qtTableResult
.WebDisableDateRecognition = True
.Refresh
.Delete
End With
strWbName = Mid(strFileName, 1, _
Len(strFileName) - 5)
wkbBook.SaveAs Filename:=strPath & _
strWbName & ".xls", _
FileFormat:=xlNormal
wkbBook.Close
strFileName = Dir
Else
strFileName = Dir
End If
Loop
End If
End If
If intTMP = 0 Then
MsgBox "No HTML file!"
Else
MsgBox intTMP & " HTML >>> XLS!"
End If
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objShell = Nothing
Set varDir = Nothing
End Sub
Public Sub Save_HTML_XLS()
Dim strFileName As String
Dim strWbName As String
Dim objShell As Object
Dim intTMP As Integer
Dim strPath As String
Dim varDir As Variant
Dim lngRow As Long
On Error GoTo Fin
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Ordner", &H1000, 17)
If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
strPath = varDir.Self.Path
If strPath <> "" Then
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strFileName = Dir(strPath)
If strFileName <> "" Then
Do While strFileName <> ""
If strFileName Like "*.ht*" Then
Call HTML_Change(strPath, strFileName)
intTMP = intTMP + 1
Workbooks.Open Filename:=strPath & strFileName
For lngRow = 1 To Range("A" & Rows.Count).End(xlUp).Row
Cells(lngRow, 1).NumberFormat = "@"
Cells(lngRow, 1) = Replace(Cells(lngRow, 1), "'", "")
Next lngRow
strWbName = Mid(ActiveWorkbook.Name, 1, _
Len(ActiveWorkbook.Name) - 5)
ActiveWorkbook.SaveAs Filename:=strPath & _
strWbName & ".xls", _
FileFormat:=xlNormal
ActiveWorkbook.Close
strFileName = Dir
Else
strFileName = Dir
End If
Loop
End If
End If
If intTMP = 0 Then
MsgBox "No HTML file!"
Else
MsgBox intTMP & " HTML >>> XLS!"
End If
Fin:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objShell = Nothing
Set varDir = Nothing
End Sub
Private Sub HTML_Change(ByVal strPathTMP As String, strFileTMP As String)
Dim strTempBuffer As String
Dim intFileNum As Integer
Dim strLines() As String
Dim varLines As Variant
Dim lngTMP As Long
strTempBuffer = Space(FileLen(strPathTMP & strFileTMP))
intFileNum = FreeFile
Reset
Open strPathTMP & strFileTMP For Binary Access Read _
Lock Write As #intFileNum
Get intFileNum, , strTempBuffer
Close intFileNum
strLines = Split(strTempBuffer, "<")
strTempBuffer = ""
For lngTMP = Ubound(strLines) To Lbound(strLines) Step -1
If strLines(lngTMP) Like "td>*.*" Then
If Not Len(strLines(lngTMP)) > 12 Then
strLines(lngTMP) = WorksheetFunction.Substitute _
(strLines(lngTMP), ">", ">'", 1)
End If
End If
Next lngTMP
varLines = Join(strLines, "<")
intFileNum = FreeFile
Reset
Open strPathTMP & strFileTMP For Output As #intFileNum
Print #intFileNum, varLines
Close #intFileNum
End Sub


ZIP Sample 2003 and 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...