Diesmal geht es um ein kleines Excel Makro. Gefragt war nach einer Möglichkeit um grundlegende Schriftformatierungen wie Fett- und Kursivschrift, sowie unterstrichenen Text bei einem Export ins CSV Format zu übernehmen. Die Funktion geht alle Zellen der ersten Tabelle durch und schließt formatierten Text in folgenden Zeichen ein:
- *Fettschrift*
- /Kursiv/
- _Unterstrichen_
Dadurch bleibt die Formatierung auch bei der späteren Verarbeitung der CSV Daten erhalten.
Sub Excel2CSV()
' Eine Zelle
Dim myCell As Range
' Temporärer Zelleninhalt
Dim tmpText As String
' Zellenlänge und Schleifenvariable
Dim cellLen As Integer
Dim i As Integer
' Formatierungen geöffnet
Dim openBold As Boolean
Dim openItalic As Boolean
Dim openUnderlined As Boolean
' Formatierungen des aktuellen Zeichens
Dim isBold As Boolean
Dim isItalic As Boolean
Dim isUnderlined As Boolean
' Die erste Tabelle
Set myTable = Sheets(1).UsedRange
' Alle Zellen in der Tabelle durchlaufen
For Each myCell In myTable
openBold = False
openItalic = False
openUnderlined = False
tmpText = ""
cellLen = myCell.Characters.Count
' Prüfen ob in der Zelle etwas steht
If cellLen > 0 Then
' Alle Zeichen durchlaufen
For i = 1 To cellLen
' Fettschrift ermitteln
isBold = myCell.Characters(i, 1).Font.Bold
' Kursiv ermitteln
isItalic = myCell.Characters(i, 1).Font.Italic
' Unterstrichen ermitteln
If myCell.Characters(i, 1).Font.Underline = xlUnderlineStyleNone Then
isUnderlined = False
Else
isUnderlined = True
End If
' Zeichenformatierung mit aktueller vergleichen und entsprechende
' Formatzeichen einfügen
If Not openBold = isBold Then
tmpText = tmpText + "*"
openBold = isBold
End If
If Not openItalic = isItalic Then
tmpText = tmpText + "/"
openItalic = isItalic
End If
If Not openUnderlined = isUnderlined Then
tmpText = tmpText + "_"
openUnderlined = isUnderlined
End If
' Zeichen übertragen
tmpText = tmpText + myCell.Characters(i, 1).Text
Next i
' Offene Formatierungen am Ende schließen
If openBold Then
tmpText = tmpText + "*"
End If
If openItalic Then
tmpText = tmpText + "_"
End If
If openUnderlined Then
tmpText = tmpText + "_"
End If
' Neuen Zelleninhalt übertragen
myCell = tmpText
End If
Next myCell
End SubDies ist mehr oder weniger mein erstes Excel Makro und ich bin kein VB Experte, daher kann es gut sein, dass Optimierungen möglich sind 
