AW: Über VBA Schriftgröße einstellen.
28.12.2018 13:25:26
Nepumuk
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