Über VBA Schriftgröße einstellen.

Michael · 2018-12-28T08:24:36+00:00

Hallo User, als Leihe wende ich mich heute an Euch mit der bitte um Unterstützung bei der Erstellung eines VBA-Macro. Ich möchte gerne die Schriftgröße einer Excel Zeile ändern, wenn sich in einer Zelle dieser Zeile ein definierter Text steht. Z.B. in Zelle B2, A6 und D21 steht das Wort "Nacharbeit" so sollen dann nur die Zeilen 2, 6 und 21 die im Macro festgelegte Schriftgröße erhalten. Schön wäre es auch, wenn man gleich dabei eine andere Schriftart festlegen könnte. Die anderen Zeilen sollen davon unberührt bleiben. Danke für Eure Unterstützung

Hallo Micha,
ich bin jetzt mal davon ausgegangen dass sich deine "Nacharbeit" in Tabelle1 befindet. Daher im Modul "DieseArbeitsmappe": Call Tabelle1.SetDictionary bzw. Call Tabelle1.ResetDictionary. Tabelle1 ist in dem Fall der Objektname der Tabelle. Den findest du im Projektexplorer vor dem in Klammern stehenden Tabellennamen auf der Exceloberfläche.
in das Modul "DieseArbeitsmappe":

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not Saved Then
        Select Case MsgBox("Sollen Ihre Änderungen in '" & Name & _
                    "' gespeichert werden", vbExclamation Or vbYesNoCancel)
            Case vbYes
                Save
            Case vbNo
                Saved = True
            Case vbCancel
                Cancel = True
        End Select
    End If
    If Not Cancel Then Call Tabelle1.ResetDictionary
End Sub

Private Sub Workbook_Open()
    Call Tabelle1.SetDictionary
End Sub

In das Modul der Tabelle:

Option Explicit

Private Const REWORK_TERM As String = "Nacharbeit"

Private lobjDictionary As Object

Friend Sub SetDictionary()
    Dim objCell As Range
    Dim strFirstAddress As String
    Set lobjDictionary = CreateObject("Scripting.Dictionary")
    Set objCell = Cells.Find(What:=REWORK_TERM, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
    If Not objCell Is Nothing Then
        strFirstAddress = objCell.Address
        Do
            Call lobjDictionary.Add(Key:=objCell.Address, Item:=vbNullString)
            Set objCell = Cells.FindNext(After:=objCell)
        Loop Until objCell.Address = strFirstAddress
    End If
End Sub

Friend Sub ResetDictionary()
    Call lobjDictionary.RemoveAll
    Set lobjDictionary = Nothing
End Sub

Private Sub Worksheet_Calculate()
    Dim objCell As Range
    Dim vntDictionaryKey As Variant
    Dim strFirstAddress As String
    Dim blnFound As Boolean
    Set objCell = Cells.Find(What:=REWORK_TERM, LookIn:=xlValues, _
        LookAt:=xlWhole, MatchCase:=True)
    If Not objCell Is Nothing Then
        strFirstAddress = objCell.Address
        Do
            For Each vntDictionaryKey In lobjDictionary.Keys
                If vntDictionaryKey = objCell.Address Then
                    Call lobjDictionary.Remove(objCell.Address)
                    blnFound = True
                    Exit For
                End If
            Next
            If Not blnFound Then 'Zelle mit "Nacharbeit" gefunden
                With objCell.EntireRow.Font
                    If .Size <> 12 Then 'Wenn Zeile noch nicht formatiert
                        .Size = 12 'neue Schriftgröße
                        .Bold = True 'neue Fett
                        .FontStyle = "Verdana" 'neue Schriftart
                    End If
                End With
            Else
                blnFound = False
            End If
            Set objCell = Cells.FindNext(After:=objCell)
        Loop Until objCell.Address = strFirstAddress
    End If
    For Each vntDictionaryKey In lobjDictionary.Keys
        With Range(vntDictionaryKey).EntireRow.Font 'Zelle die vorher "Nacharbeit" enthalten haben zurücksetzen
            .Size = 10 'alte Schriftgröße
            .Bold = False 'alte Fett
            .FontStyle = "Arial" 'alte Schriftart
        End With
    Next
    Call ResetDictionary
    Call SetDictionary
End Sub

Gruß
Nepumuk

Hallo Michael
als Laie kann man nicht alles wissen, schön das es Forum Ratgeber gibt.
Mit dem unteren Code dürften alle Wünsche erfüllbar sein. Du must ihn aber auf deine Bedürfnisse anpassen, denn ich habe dir gezeigt wie es grundsaetzlich geht. Da sind Funktionen dabei die du vielleicht NIHT brauchst. Dann diese Zeilen in deinem Makro löschen!!
Du kannst bei Const die Schriftfarbe, Grösse und Innenfarbe als Zahlenwert eingeben. Entsprechend wird die Zelle gesetzt. Nach ein paar mal ausprobieren in einer Beispiel Datei hast du den Dreh schnell raus. Bitte zuerst in einer Kopie Datei testen, NICHT im Original, bis das Makro einwandfrei funktioniert. Dann kannst du es ins Original übernehmen.
Bei rFind.Font.Color oder ColorIndex kann es Laufzeitfehler geben, weil ColorIndex im alten Excel 97 nur kleine Zahlen von 1-56 für Farben hatte. Mit Color kann man die heutigen sehr langen Zahlen bei Farbe einstellen! Die gewünschte Farbe kannst du mit dem Makro Recorder aufzeichnen, und den Zahlenwert in Const übernehmen. Ob du mit Color oder ColorIndex hinkommst must du selbst testen.
Im Fehlerfall erscheint ein Dialog "Laufzeitfehler" den du mit Ende oder Debut abklicken kannst. Bei Debug zeigt er dir die defekte Makrozeile in Gelb, danach must du mit Reset im Menü Run den Stopp beseitigen. Sonst funktioniert kein Makro mehr!
Ein frohes neues Jahr, und viel Spass beim Selbst dein eigenes VBA Makro basteln ...
mfg Piet

Const Farbe = 3    '3=Rot Schriftfarbe
Const Grösse = 8   'Schriftgrösse
Const Innen = 4    'Zell-Innenfarbe
Sub Schrift_aendern()
Dim Adr1 As String, rFind As Range, Zahl As Integer
If Application.WorksheetFunction.CountIf(ActiveSheet.UsedRange, "Nacharbeit") > 0 Then
Zahl = Application.WorksheetFunction.CountIf(ActiveSheet.UsedRange, "Nacharbeit")
MsgBox Zahl & "  Zellen mit Nacharbeit im Blatt"
Set rFind = Cells.Find(What:="Nacharbeit", After:=[A1], LookIn:=xlValues, LookAt:=xlWhole)
If Not rFind Is Nothing Then
Adr1 = rFind.Address
Do
rFind.Font.Size = Grösse            'Schriftgrösse
rFind.Font.Color = Farbe            'Schriftfarbe  (lange Zahl)
rFind.Font.ColorIndex = Farbe       'Schriftfarbe  (1-56)
rFind.Font.Italic = True            'Schraegschrift/ Italian
rFind.Font.Bold = False             'Fettschrift = True/False
'Zelle mit Innenfarbe versehen
rFind.Interior.ColorIndex = Innen   'Innenfarbe
'Zelle mittig zentrieren, oder Rechts, Links
rFind.HorizontalAlignment = xlCenter  'xlRight, xlLeft
Set rFind = Cells.FindNext(After:=rFind)
Loop Until rFind.Address = Adr1
End If
End If
End Sub

Über VBA Schriftgröße einstellen.

Forumthread: Über VBA Schriftgröße einstellen.

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Schriftgröße in Excel mit VBA anpassen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

Über VBA Schriftgröße einstellen.

Forumthread: Über VBA Schriftgröße einstellen.

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

Schriftgröße in Excel mit VBA anpassen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread