hallo allerseits
ich suche eine lösung in excel nach einer bestimmten schriftart arial zu suchen (hat mehrere im Dokument) und diese mit einer anderen schriftart zu ersetzen und die schriftgrösse gleichzeitig um plus 1 zu erhöhen.
danke für evtl. lösungsvorschläge.
zf
Hallo zf
ich suche eine lösung in excel nach einer bestimmten
schriftart arial zu suchen (hat mehrere im Dokument) und diese
mit einer anderen schriftart zu ersetzen und die schriftgrösse
gleichzeitig um plus 1 zu erhöhen.
Eine Möglichkeit wäre über den Suchen/Ersetzen-Dialog (zumindest unter Excel 2007) wenn man die Option Formate mit nutzt. Allerdings muss man, wenn mehrere Schriftgrößen vorkommen jede Größe einzeln ersetzen.
Alternativ geht es per Makro. siehe nachfolgendes Beispiel.
Falls man diese Aktion öfters benötigt, dann sollte man sich ein kleines Usersform anlegen. Hier kann man den Bedienungskomfort erhöhen, indem die Font-Namen in Comboboxen als Auswahlliste zur Verfügung stellt.
Gruß
Franz
Sub AendernFontundGroesse()
Dim sFont\_Neu As String, sFont\_Alt As String, sFontZelle As String
Dim MsgPrompt As String, MsgTitel As String, sText As String, vDefault
Dim vDelta As Variant, Zelle As Range
On Error GoTo Fehler
MsgTitel = "Font-Name und -Größe ändern"
vDefault = "Arial"
sText = "Alter Font-Name" & vbNewLine & "(genaue Schreibweise beachten!)"
MsgPrompt = sText
Eingabe\_Font\_Alt:
sFont\_Alt = InputBox(MsgPrompt, MsgTitel, vDefault)
If sFont\_Alt = "" Then GoTo Beenden
If Check\_Font\_Name(sFont\_Alt) = False Then
MsgPrompt = sText & vbNewLine & "Font ist falsch geschrieben!"
vDefault = sFont\_Alt
GoTo Eingabe\_Font\_Alt
End If
sText = "Neuer Font-Name" & vbNewLine & "(genaue Schreibweise beachten!)"
MsgPrompt = sText
vDefault = sFont\_Alt 'statt altem Font-Namen kann man \_
auch einen anderen Namen als Default vorgeben
Eingabe\_Font\_Neu:
sFont\_Neu = InputBox(MsgPrompt, MsgTitel, vDefault)
If Check\_Font\_Name(sFont\_Neu) = False Then
MsgPrompt = sText & vbNewLine & "Font ist falsch geschrieben!"
vDefault = sFont\_Neu
GoTo Eingabe\_Font\_Neu
End If
If sFont\_Neu = "" Then GoTo Beenden
sText = "Größen-Änderung?" & vbNewLine & "(Zahlenwert, ggf. mit Minuszeichen)"
MsgPrompt = sText
Eingabe\_Groesse:
vDelta = InputBox(MsgPrompt, MsgTitel, 1)
If vDelta = "" Then GoTo Beenden
If IsNumeric(vDelta) Then
For Each Zelle In ActiveSheet.UsedRange
With Zelle.Font
If .Name = sFont\_Alt Then
.Name = sFont\_Neu
.Size = .Size + CDbl(vDelta)
End If
End With
Next
Else
MsgPrompt = sText & vbNewLine & \_
"Für die Größenänderung muss ein nummerischer Wert eingegeben werden!"
GoTo Eingabe\_Groesse
End If
Beenden:
'Fehlerbehandlung
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'kein Fehler
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Function Check\_Font\_Name(sFontName As String) As Boolean
'Prüft ob Fontname in Auswahlliste für Fontnamen vorhanden
Dim objControl As CommandBarControl
Dim intCounter As Integer
Set objControl = Application.CommandBars.FindControl(ID:=1728)
With objControl
For intCounter = 1 To .ListCount
If LCase(sFontName) = LCase(.List(intCounter)) Then
Check\_Font\_Name = True: Exit For
End If
Next
End With
End Function
Herzlichen Dank Franz, funktioniert bestens. Noch einen schönen Sonntag. Grüsse, zf