10.02.2009

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

Filter - Data - Copy!

A few simple examples, how filtered data are copied. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1"


Ein paar einfache Beispiele, wie gefilterte Daten kopiert werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1"


Option Explicit
Public Sub Step_1()
Dim wksSheetQ As Worksheet
Dim wksSheetZ As Worksheet
Dim rngTMP As Range
On Error GoTo Fin
Application.ScreenUpdating = False
Set wksSheetZ = Sheet1
Set wksSheetQ = Worksheets.Add
With wksSheetQ
.Cells.Clear
Set rngTMP = wksSheetZ.Range("A2"). _
CurrentRegion.SpecialCells(xlCellTypeVisible)
rngTMP.Copy .Range("A1")
End With
Fin:
Set rngTMP = Nothing
Application.ScreenUpdating = True
End Sub
Public Sub Step_3()
Dim wksSheetQ As Worksheet
Dim wksSheetZ As Worksheet
Dim rngTMP As Range
On Error GoTo Fin
Application.ScreenUpdating = False
Set wksSheetZ = Sheet1
Set wksSheetQ = Worksheets.Add
With wksSheetQ
.Cells.Clear
wksSheetZ.Range("A1").AutoFilter Field:=1, _
Criteria1:=wksSheetZ.Range("G1").Value
Set rngTMP = wksSheetZ.Range("A2").CurrentRegion. _
SpecialCells(xlCellTypeVisible)
rngTMP.Copy .Range("A1")
End With
Fin:
Set rngTMP = Nothing
Application.ScreenUpdating = True
End Sub
Public Sub Step_5()
Dim wksSheetQ As Worksheet
Dim wksSheetZ As Worksheet
Dim intTMP As Integer
Dim lngRow As Long
On Error GoTo Fin
Application.ScreenUpdating = False
Set wksSheetZ = Sheet1
Set wksSheetQ = Worksheets.Add
With wksSheetZ
.Range("A1").AutoFilter Field:=1, _
Criteria1:=.Range("G1").Value
For intTMP = 1 To WorksheetFunction.CountA(.Columns(1))
If .Rows(intTMP).Hidden = False Then
lngRow = lngRow + 1
wksSheetQ.Cells(lngRow, 1).Value = _
.Cells(intTMP, 1).Value
End If
Next intTMP
End With
Fin:
Application.ScreenUpdating = True
End Sub
Public Sub Step_2_4_6()
With Sheet1
If .FilterMode Then .ShowAllData
End With
End Sub


Sample 2003

Sample 2007

TextBox - Formatted - Word!

The content of a TextBox (in Excel 2007 from "Insert - Text - TextBox") is inserted formatted in a new Word document. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1"


Der Inhalt einer Textbox (in Excel 2007 aus "Einfügen - Text - Textfeld") wird formatiert in ein neues Worddokument eingefügt. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1"


Option Explicit
Public Sub Test()
Dim objDocument As Object
Dim intHeight As Integer
Dim intWidth As Integer
Dim objWDApp As Object
Dim shpShape As Shape
Dim intTMP As Integer
Application.ScreenUpdating = False
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = _
CreateObject("Word.Application")
On Error GoTo 0
On Error GoTo Fin
Set objDocument = objWDApp.Documents.Add
objWDApp.Visible = True
For Each shpShape In ThisWorkbook.Worksheets(1).Shapes
If shpShape.Type = msoTextBox Then
With ThisWorkbook.Worksheets(1)
intWidth = .Columns("A:A").ColumnWidth
intHeight = .Rows("1:1").RowHeight
.Columns("A:A").ColumnWidth = 150
.Rows("1:1").RowHeight = 35
End With
ThisWorkbook.Worksheets(1).Range("A1").Value = _
shpShape.TextFrame.Characters.Text
For intTMP = 1 To Len(shpShape.TextFrame.Characters.Text)
With ThisWorkbook.Worksheets(1). _
Range("A1").Characters(intTMP).Font
.Size = shpShape.TextFrame. _
Characters(intTMP, 1).Font.Size
.ColorIndex = shpShape.TextFrame. _
Characters(intTMP, 1).Font.ColorIndex
.Bold = shpShape.TextFrame. _
Characters(intTMP, 1).Font.Bold
.Underline = shpShape.TextFrame. _
Characters(intTMP, 1).Font.Underline
End With
Next intTMP
With ThisWorkbook.Worksheets(1)
.Range("A1").Copy
objDocument.Windows(1).Selection.Paste
objDocument.Tables(1).AutoFitBehavior (1)
Application.CutCopyMode = False
.Range("A1").Clear
.Columns("A:A").ColumnWidth = intWidth
.Rows("1:1").RowHeight = intHeight
End With
End If
Next shpShape
Fin:
Application.ScreenUpdating = True
Set objWDApp = Nothing
End Sub


Sample 2003

Sample 2007

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...