Beschreibung

Es gibt Fälle, in denen in Worddokumenten der Zellenhintergrund in Tabellen abhängig vom Text der Tabellenzelle gesetzt werden muss. Wenn das im ganzen Dokument nach dem gleichen Regelwerk erfolgen soll, kann ein Makro die Arbeit deutlich vereinfachen.

Das folgende Makro habe ich daher auf Nachfrage eines Blogbesuchers erstellt. Das Makro durchsucht alle Tabellen im geöffneten Dokument nach zwei vorgegebenen Zeichenketten (case-sensitiv!), die über die beiden Variablen strString1 und strString2 definiert sind. Aktuell sind die Zeichenketten „orange“ und „rot“ eingestellt.

strString1 = "orange"
strString2 = "rot"

Die Zellenhintergrundfarben werden über die beiden Variablen lFarbe1 und lFarbe2 definiert.

lFarbe1 = 49407       ' orange
lFarbe2 = wdColorRed  ' rot

lFarbe1 definiert dabei die Farbe für die Zeichenkette strString1, lFarbe2 für strString2.

Sourcecode

Public Sub ZellenhintergrundFaerben()
    ' Definition der Zelleninhalte für die Hintergrundfarben
    Dim strString1 As String
    Dim strString2 As String
    
    strString1 = "orange"
    strString2 = "rot"
    
    ' Definition der Zelleninhalte für die Hintergrundfarben
    Dim lFarbe1 As Long
    Dim lFarbe2 As Long
    
    lFarbe1 = 49407       ' orange
    lFarbe2 = wdColorRed  ' rot


    On Error GoTo NoDocumentOpen
    If Len(ActiveDocument.Name) = 0 Then GoTo NoDocumentOpen
    
    Dim oCurTable As Table
    Dim strCurCellText As String
    
    For Each oCurTable In ActiveDocument.Tables
        Dim oCurRow As Row
        
        With oCurTable
            For Each oCurRow In .Rows
                Dim oCurCell As Cell

                For Each oCurCell In oCurRow.Cells
                
                    ' Bildschirmaktualisierung abschalten
                    Application.ScreenUpdating = False
                    
                    ' Zelleinhalt ermitteln und ggfs. um 2 Stellen kürzen
                    strCurCellText = oCurCell.Range
                   
                    If Len(strCurCellText) >= 2 Then
                        strCurCellText = Left(strCurCellText, Len(strCurCellText) - 2)
                    End If
                    
                    ' Zellenhintergrundfarbe setzen
                    If StrComp(strCurCellText, strString1) = 0 Then
                        oCurCell.Shading.BackgroundPatternColor = lFarbe1
                    ElseIf StrComp(strCurCellText, strString2) = 0 Then
                        oCurCell.Shading.BackgroundPatternColor = lFarbe2
                    End If
                                            
                Next oCurCell
            Next oCurRow
        End With
    Next oCurTable

NoDocumentOpen:
    ' Bildschirmaktualisierung einschalten
    Application.ScreenUpdating = True
End Sub

Und hier noch eine erweiterte Version, falls nicht nur für die Zelle mit der gesuchten Zeichenkette selbst, sondern auch für die linke Nachbarzelle (sofern vorhanden) der Zellenhintergrund gesetzt werden soll.

Sourcecode (auch den Zellenhintergrund der linken Nachbarzelle setzen)

Public Sub ZellenhintergrundFaerben()
    ' Definition der Zelleninhalte für die Hintergrundfarben
    Dim strString1 As String
    Dim strString2 As String
    
    strString1 = "orange"
    strString2 = "rot"
    
    ' Definition der Zelleninhalte für die Hintergrundfarben
    Dim lFarbe1 As Long
    Dim lFarbe2 As Long
    
    lFarbe1 = 49407       ' orange
    lFarbe2 = wdColorRed  ' rot


    On Error GoTo NoDocumentOpen
    If Len(ActiveDocument.Name) = 0 Then GoTo NoDocumentOpen
    
    Dim oCurTable As Table
    Dim strCurCellText As String
    
    For Each oCurTable In ActiveDocument.Tables
        Dim oCurRow As Row
        
        With oCurTable
            For Each oCurRow In .Rows
                Dim oCurCell As Cell

                For Each oCurCell In oCurRow.Cells
                
                    ' Bildschirmaktualisierung abschalten
                    Application.ScreenUpdating = False
                    
                    ' Zelleinhalt ermitteln und ggfs. um 2 Stellen kürzen
                    strCurCellText = oCurCell.Range
                   
                    If Len(strCurCellText) >= 2 Then
                        strCurCellText = Left(strCurCellText, Len(strCurCellText) - 2)
                    End If
                    
                    If StrComp(strCurCellText, strString1) = 0 Then
                        ' Zellenhintergrundfarbe setzen
                        oCurCell.Shading.BackgroundPatternColor = lFarbe1
                        ' Zellenhintergrundfarbe der linken Nachbarzelle (sofern vorhanden) setzen
                        If oCurCell.ColumnIndex >= 1 Then
                            oCurTable.Cell(oCurRow.Index, oCurCell.ColumnIndex - 1).Shading.BackgroundPatternColor = lFarbe1
                        End If
                    ElseIf StrComp(strCurCellText, strString2) = 0 Then
                        ' Zellenhintergrundfarbe setzen
                        oCurCell.Shading.BackgroundPatternColor = lFarbe2
                        ' Zellenhintergrundfarbe der linken Nachbarzelle (sofern vorhanden) setzen
                        If oCurCell.ColumnIndex >= 1 Then
                            oCurTable.Cell(oCurRow.Index, oCurCell.ColumnIndex - 1).Shading.BackgroundPatternColor = lFarbe2
                        End If
                    End If
                                            
                Next oCurCell
            Next oCurRow
        End With
    Next oCurTable

NoDocumentOpen:
    ' Bildschirmaktualisierung einschalten
    Application.ScreenUpdating = True
End Sub