AW: Eine Art Autokorrektur mit Astrofonts?
03.12.2008 14:20:00
fcs
Hallo Born,
das kann man über Ereignismakros, die auf Zellwert-Änderungen reagieren, steuern.
Hier mal am Beispiel mit Schriftart "Wingdings".
Problem ist natürlich, dass alle Zellen, die mit diesen Textteilen anfangen, angepasst und umformatiert werden.
In meinem Beispiel werden alle Zellen der Tabellenblätter angepasst. Die Prozedur muss du im VBA-editor unter "DieseArbeitsmappe" einfügen. Die Textkürzel für die Planeten/Tierkreiszeichen und die Nummern der zugehörigen Zeichen muss du an deinen Astrologie-Zeichensatz anpassen.
Ggf. muss du das Ganze noch etwas verfeinern und die Funktion auf bestimmte Spalten/Zellbereiche beschränken oder auch je Tabellenblatt eine Worksheet_Change-Prozedur anlegen, statt eine, die alle Sheets einer Mappe abdeckt.
Insgesamt wäre es aber wesentlich einfacher, wenn du die Symbole und den weiteren Text in separaten Spalten eintragen würdest.
Gruß
Franz
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Sondertext umwandlungen
Dim rngZ As Range, bolZeichen As Boolean, lngZeichen As Long
Select Case Sh.Name
Case "Tabelelle X", "Tabelle Y"
'do nothing, Tabeleln in denen diese Funktion nicht aktiv sein soll
Case Else
For Each rngZ In Target
If rngZ.HasFormula = False Then
'Planeten Check
If Left(rngZ, 3) = "Son" Then
Call Zeichen(Zelle:=rngZ, lNr:=89, iLang:=3)
ElseIf Left(rngZ, 3) = "Mer" Then
Call Zeichen(Zelle:=rngZ, lNr:=110, iLang:=3)
ElseIf Left(rngZ, 3) = "Ven" Then
Call Zeichen(Zelle:=rngZ, lNr:=113, iLang:=3)
ElseIf Left(rngZ, 3) = "Erd" Then
Call Zeichen(Zelle:=rngZ, lNr:=112, iLang:=3)
ElseIf Left(rngZ, 3) = "Mar" Then
Call Zeichen(Zelle:=rngZ, lNr:=111, iLang:=3)
ElseIf Left(rngZ, 3) = "Jup" Then
Call Zeichen(Zelle:=rngZ, lNr:=116, iLang:=3)
ElseIf Left(rngZ, 3) = "Sat" Then
Call Zeichen(Zelle:=rngZ, lNr:=109, iLang:=3)
ElseIf Left(rngZ, 3) = "Ura" Then
Call Zeichen(Zelle:=rngZ, lNr:=117, iLang:=3)
ElseIf Left(rngZ, 3) = "Nep" Then
Call Zeichen(Zelle:=rngZ, lNr:=117, iLang:=3)
ElseIf Left(rngZ, 3) = "Plu" Then
Call Zeichen(Zelle:=rngZ, lNr:=115, iLang:=3)
End If
'Sternzeichen-Check
If Left(rngZ, 3) = "Was" Then 'Wassermann (21. Januar - 19. Februar)
Call Zeichen(Zelle:=rngZ, lNr:=104, iLang:=3)
ElseIf Left(rngZ, 3) = "Fis" Then 'Fische (20. Februar - 20. März)
Call Zeichen(Zelle:=rngZ, lNr:=105, iLang:=3)
ElseIf Left(rngZ, 3) = "Wid" Then 'Widder (21. März - 20. April)
Call Zeichen(Zelle:=rngZ, lNr:=94, iLang:=3)
ElseIf Left(rngZ, 3) = "Sti" Then 'Stier (21. April - 20. Mai)
Call Zeichen(Zelle:=rngZ, lNr:=95, iLang:=3)
ElseIf Left(rngZ, 3) = "Zwi" Then 'Zwillinge (21. Mai - 21. Juni)
Call Zeichen(Zelle:=rngZ, lNr:=96, iLang:=3)
ElseIf Left(rngZ, 3) = "Kre" Then 'Krebs (22. Juni - 22. Juli)
Call Zeichen(Zelle:=rngZ, lNr:=97, iLang:=3)
ElseIf Left(rngZ, 3) = "Löw" Then 'Löwe (23. Juli - 23. August)
Call Zeichen(Zelle:=rngZ, lNr:=98, iLang:=3)
ElseIf Left(rngZ, 3) = "Jun" Then 'Jungfrau (24. August - 23. September)
Call Zeichen(Zelle:=rngZ, lNr:=99, iLang:=3)
ElseIf Left(rngZ, 3) = "Waa" Then 'Waage (24. September - 23. Oktober)
Call Zeichen(Zelle:=rngZ, lNr:=100, iLang:=3)
ElseIf Left(rngZ, 3) = "Sko" Then 'Skorpion (24. Oktober - 22. November)
Call Zeichen(Zelle:=rngZ, lNr:=101, iLang:=3)
ElseIf Left(rngZ, 3) = "Sch" Then 'Schütze (23. November - 21. Dezember)
Call Zeichen(Zelle:=rngZ, lNr:=102, iLang:=3)
ElseIf Left(rngZ, 3) = "Ste" Then 'Steinbock (22. Dezember - 20. Januar)
Call Zeichen(Zelle:=rngZ, lNr:=103, iLang:=3)
End If
End If
Next
End Select
End Sub
Sub Zeichen(Zelle As Range, lNr As Long, iLang As Integer, _
Optional strFont As String = "Wingdings", Optional strFontText As String = "Arial")
'Zelle = Anzupassende Zelle
'lNr = Nr des Zeichens im Zeichensatz
'iLang = Länge des durch das Zeichen zu ersetzenden Textes
'strFont = Name des Fonts für das 1. Zeichen, Vorgabe = "Wingdings"
'strFontText = name des Fonts für den restlichen Text, Vorgabe = "Arial"
Zelle.Value = Chr(lNr) & Mid(Zelle.Value, iLang + 1)
Zelle.Characters(1, 1).Font.Name = strFont
Zelle.Characters(2, Len(Zelle.Value) - 1).Font.Name = strFontText
End Sub