Auslesen von Formatierungen mit .characters

Hallo,
ich hab hier ein Excel-Sheet vorliegen, bei dem massig Formatierungen innerhalb von Zellen vorgenommen worden sind. Es sind so ca. 1000 Zellen mit Textlängen zwischen 200 und 500 Zeichen, die ich auslesen und in HTML-Code verwandeln möchte, wobei mich nur die Formatierungen
- Fett
- Kursiv
- Schriftfarbe rot (font.colorindex=3)
interesseren.
Soweit ich weiß, kriegt man das nur über die .characters-Eigenschaft raus. Meine bisherige Lösung (nur der Teil, der die Verwandlung vornimmt) sieht folgendermaßen aus:

Function fctHTMLFormat2(r As Range, w As Integer) As String
 Dim strE As String
 Dim i As Integer, l As Integer, j As Integer

 If w = vbNo Then
 fctHTMLFormat2 = r.Value
 Exit Function
 End If

 l = Len(r)
 j = 1
 If InStr(1, r.Characters(1, 1).Font.FontStyle, "Fett") <> 0 Then
 strE = strE & ""
 End If
 If InStr(1, r.Characters(1, 1).Font.FontStyle, "Kursiv") <> 0 Then
 strE = strE & ""
 End If
 If r.Characters(1, 1).Font.ColorIndex = 3 Then
 strE = strE & ""
 End If
 For i = 2 To l
 If r.Characters(i, 1).Font.FontStyle <> r.Characters(i - 1, 1).Font.FontStyle Then
 strE = strE & Mid(r, j, i - j)
 j = i
 If InStr(1, r.Characters(i, 1).Font.FontStyle, "Fett") <> 0 And _
 InStr(1, r.Characters(i - 1, 1).Font.FontStyle, "Fett") = 0 Then
 strE = strE & ""
 End If
 If InStr(1, r.Characters(i, 1).Font.FontStyle, "Fett") = 0 And _
 InStr(1, r.Characters(i - 1, 1).Font.FontStyle, "Fett") <> 0 Then
 strE = strE & ""
 End If
 If InStr(1, r.Characters(i, 1).Font.FontStyle, "Kursiv") <> 0 And _
 InStr(1, r.Characters(i - 1, 1).Font.FontStyle, "Kursiv") = 0 Then
 strE = strE & ""
 End If
 If InStr(1, r.Characters(i, 1).Font.FontStyle, "Kursiv") = 0 And _
 InStr(1, r.Characters(i - 1, 1).Font.FontStyle, "Kursiv") <> 0 Then
 strE = strE & ""
 End If
 End If
 If r.Characters(i, 1).Font.ColorIndex <> r.Characters(i - 1, 1).Font.ColorIndex Then
 strE = strE & Mid(r, j, i - j)
 j = i
 If r.Characters(i, 1).Font.ColorIndex = 3 Then
 strE = strE & ""
 Else
 strE = strE & ""
 End If
 End If
 Next
 strE = strE & Mid(r, j, i - j)
 If InStr(1, r.Characters(l, 1).Font.FontStyle, "Fett") <> 0 Then
 strE = strE & ""
 End If
 If InStr(1, r.Characters(l, 1).Font.FontStyle, "Kursiv") <> 0 Then
 strE = strE & ""
 End If
 If r.Characters(l, 1).Font.ColorIndex = 3 Then
 strE = strE & ""
 End If

 fctHTMLFormat2 = strE
End Function

Es ist also eine Funktion, die ein Range-Objekt (jeweils eine Zelle) auswertet und das Ergebnis als String (mit HTML-Tags) zurückgibt. Dass aus den einzelnen Strings ein größerer String zusammengesetzt wird (der u.a. HTML-Tabellen enthält) spielt hier nicht zur Sache. Denn das Problem ist ganz eindeutig diese Funktion.
Eigentlich macht die Funktion perfekt das, was ich will - jedoch dauert sie viel zu lange!
Der Parameter w ist dazu da, testweise auf das Auslesen der Formatierungen zu verzichten, bei w=vbNo=7 wird einfach der komlette Zellinhalt als String zurückgegeben, ansonsten erfolgt die detaillierte Format-Auswertung.
OHNE diese Format-Auswertung wird der komplette Code (von allen 1000 Zellen) in ca 2 Sekunden erzeugt, MIT hingegen dauert es je nach "Laune" von Excel zwischen 90 Sekunden und 20 Minuten!!
Hat einer 'ne Ahnung, woran das liegt oder 'ne Idee, wie es eleganter geht?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo ?,
probier doch mal die folgende Funktion.

Function RangetoHTML(rng As Range)
  ' Changed by Ron de Bruin 28-Oct-2006
  ' Working in Office 2000-2010
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook

  TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

  'Copy the range and create a new workbook to past the data in
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With

  'Publish the sheet to a htm file
  With TempWB.PublishObjects.Add( _
      SourceType:=xlSourceRange, _
      Filename:=TempFile, _
      Sheet:=TempWB.Sheets(1).Name, _
      Source:=TempWB.Sheets(1).UsedRange.Address, _
      HtmlType:=xlHtmlStatic)
    .Publish (True)
  End With

  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.ReadAll
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    "align=left x:publishsource=")

  'Close TempWB
  TempWB.Close savechanges:=False

  'Delete the htm file we used in this function
  Kill TempFile

  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function

Gruß Sepp

Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2010 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 'Copy the range and create a new workbook to past the data in Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) rng.EntireColumn.Copy 'Spaltenbreiten kopieren .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats .UsedRange.ClearFormats 'Zellbereich kopieren rng.Copy .Cells(1, 1) Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.Delete On Error GoTo 0 End With 'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With 'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.ReadAll ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=") 'Close TempWB TempWB.Close savechanges:=False 'Delete the htm file we used in this function Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function

Function fctHTMLFormat2(r As Range, w As Integer) As String Dim strE As String, sText As String Dim i As Integer, l As Integer, j As Integer Dim arrStyle() As String, arrFett() As Boolean, arrItalic() As Boolean, _ arrColorIndex3() As Boolean sText = r.Value If w = vbNo Then fctHTMLFormat2 = sText Exit Function End If l = Len(sText) ReDim arrStyle(1 To l), arrFett(1 To l), arrItalic(1 To l), arrColorIndex3(1 To l) For i = 1 To l arrStyle(i) = r.Characters(i, 1).Font.FontStyle arrFett(i) = InStr(1, arrStyle(i), "Fett") 0 arrItalic(i) = InStr(1, arrStyle(i), "Kursiv") 0 arrColorIndex3(i) = r.Characters(i, 1).Font.ColorIndex = 3 Next j = 1 If arrFett(1) Then strE = strE & "" End If If arrItalic(1) Then strE = strE & "" End If If arrColorIndex3(1) Then strE = strE & "" End If For i = 2 To l If arrStyle(i) arrStyle(i - 1) Then strE = strE & Mid(sText, j, i - j) j = i If arrFett(i) And Not arrFett(i - 1) Then strE = strE & "" End If If Not arrFett(i) And arrFett(i - 1) Then strE = strE & "" End If If arrItalic(i) And Not arrItalic(i - 1) Then strE = strE & "" End If If Not arrItalic(i) And arrItalic(i - 1) Then strE = strE & "" End If End If If arrColorIndex3(i) arrColorIndex3(i - 1) Then strE = strE & Mid(sText, j, i - j) j = i If arrColorIndex3(i) Then strE = strE & " _ Else strE = strE & "" End If End If Next strE = strE & Mid(sText, j, i - j) If arrFett(l) Then strE = strE & "" End If If arrItalic(l) Then strE = strE & "" End If If arrColorIndex3(l) Then strE = strE & "" End If fctHTMLFormat2 = strE End Function

Beliebteste Forumthreads (12 Monate)

Auslesen von Formatierungen mit .characters

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread