Betinget formatering med VBA makroer i Excel

Betinget formatering i Excel er smart til at fremhæve celler, der opfylder eller ikke opfylder bestemte kriterier - fx værdier over en given grænse.

Imidlertid kan det have sine fordele at bruge VBA makroer i stedet, fx hvis du vil tælle de celler, som udløser betinget formatering (fx en bestemt baggrundsfarve).

En af mine kollegaer har et regneark, som dagligt importerer kvalitets- og procesdata, 24 rækker for hver dag og X kolonner, og han brugte betinget formatering til at farve celler røde, hvis sådan og sådan.

En dag sprugte han, om jeg kunne lave en makro, der talte de røde celler i hver kolonne.

Uvidende svarede jeg: "Ja, selvfølgelig" og troede, at det ville være en nem sag. Jeg tog fejl!

Når en celle er farvet med betinget formatering, er det at tælle en meget kompliceret sag, hvis det er muligt, og det var langt nemmere at skrive en makro, som læste hans betingelser og formaterede cellerne.

Herunder er der et eksempel på hvordan. Du kan kopiere koden her på siden og sætte den ind i et VBA-modul, eller du kan downloade et zipkomprimeret regneark med eksemplet. Regnearket er med engelsk tekst.

Eksemplet har en lav og/eller høj grænse for hver kolonne. Hvis en celleværdi fx er under den lave grænse, farves den rød, og antallet af røde celler i kolonnen indsættes nederst.

Intet forhindrer dig i at tilføje en Lav lav og Høj høj, men så bliver der 16 scenarier at tjekke.

Hvis du definerer en kontrolkolonne (med fx driftstid), vil værdier uden for grænserne blive ignoreret, hvis kontrolværdien ikke er = 1.

Koden benytter Ranges og indlejrede ForEach Next løkker, og der er også en kontrol af, om en given værdi er et heltal (Integer) eller ej.

Hvis du udvider tabellen mod højre, vil makroen automatisk tage de nye kolonner med.

Sub FormatCells()
Dim bL As Boolean       'True hvis der er en nedre grænse
Dim bH As Boolean       'True hvis der er en øvre grænse
Dim bRed As Boolean     'True if to be coloured red
Dim bCheck As Boolean   'True hvis der er en kontrolværdi (fx driftstid)
Dim lCols As Long       'Antal kolonner
Dim lActiveCol As Long  'Aktuel kolonne
Dim lOffset As Long     'Variabel for kolonne offset
Dim lRedCount As Long   'Tæller til røde celler
Dim dHigh As Double     'Øvre grænse
Dim dLow As Double      'Nedre grænse
Dim rMode As Range      'Rækken med flag for kontrol - her række 26
Dim rCol As Range       'Kolonnen med celler der skal kontrolleres
Dim rMCell As Range     'Range variabel til gennemløb
Dim rCell As Range      'Range variabel til kolonnegennemløb

On Error GoTo ErrorHandle

'Slår skærmopdatering fra (hastighed)
Application.ScreenUpdating = False

'Definerer tabellen for at få antal rækker. I dette eksempel
'skal tabellen starte i celle A1.
Set rMode = Range("A1").CurrentRegion

'Antal kolonner minus kolonne A med timer (00-01, 01-02 osv.)
lCols = rMode.Columns.Count - 1

'Nu definerer vi rMode som tabellens række 26 med cellerne,
'der fortæller om det er en kolonne med celler, der skal
'formateres betinget
Set rMode = Range(Range("B26"), Range("B26").Offset(0, lCols - 1))

'Nu gennemløber vi rækken, rMode, for at finde ud af, om
'kolonnen skal formaters betinget. Hvis ikke, springer vi
'videre til næste kolonne.
For Each rMCell In rMode
   'Tæl kolonnenummer op med 1
   lActiveCol = lActiveCol + 1
   
   With rMCell
      'Hvis det er en kolonne, der skal formateres betinget
      If .Value = "CF" Then
         
         'Reset variable
         bCheck = False
         lRedCount = 0
         
         'Er der en kontrolkolonne med fx driftstid?
         If IsNumeric(.Offset(1, 0).Value) And .Offset(1, 0).Value <> 0 Then
            'Offsetværdien som Long (eller Integer)
            lOffset = CLng(.Offset(1, 0).Value)
            'Tjek om offsetværdien er et heltal. Hvis ikke,
            'går makroen i fejl.
            If Abs(.Offset(1, 0).Value / lOffset) = 1 Then
               'Er det i tabellen?
               If lOffset > 0 And lOffset + lActiveCol <= lCols Then
                  bCheck = True
               ElseIf lOffset < 0 And lActiveCol + lOffset > 0 Then
                  bCheck = True
               Else
                  MsgBox "Kolonnen med kontrolværdierer ikke i " & _
                  "tabellen. Tjek din offsetværdi i celle " & .Address
               End If
            Else
               MsgBox "Kolonne-offset skal være et heltal" & _
               .Offset(1, 0).Value & " ignoreres."
            End If
         End If
                 
         'Tjek nedre grænse
         If IsEmpty(.Offset(3, 0)) = False And _
         IsNumeric(.Offset(3, 0).Value) Then
            dLow = .Offset(3, 0).Value
            bL = True
         Else
            bL = False
         End If
         
         'Tjek øvre grænse
         If IsEmpty(.Offset(4, 0)) = False And _
         IsNumeric(.Offset(4, 0).Value) Then
            dHigh = .Offset(4, 0).Value
            bH = True
         Else
            bH = False
         End If
         
         'Hvis der hverken er nedre eller øvre grænse
         'går vi videre til næste kolonne.
         If bL = False And bH = False Then GoTo Skip
         
         'Nu er vi klar til at gennemløbe cellerne og tjekke
         'om de skal formateres betinget.
         Set rCol = Range(.Offset(-1, 0), .Offset(-24, 0))
         
         'Der er tre scenarier med nedre og øvre grænse. Faktisk
         'er der fire, men vi har allerede tjekket for
         'bL = False and bH = False
         'Scenario 1:
         If bL And bH Then
            For Each rCell In rCol
               bRed = False 'Reset flag
               With rCell
                  'Hvis værdien er under eller over grænsen,
                  'får cellen rød baggrundsfarve.
                  If .Value < dLow Or .Value > dHigh Then
                     If bCheck And .Offset(0, lOffset).Value = 1 Then
                        bRed = True
                     ElseIf bCheck = False Then bRed = True
                     End If
                  End If
                  If bRed Then
                     .Interior.ColorIndex = 3
                     .Interior.Pattern = xlSolid
                     lRedCount = lRedCount + 1
                  Else
                     'Ingen farve
                     .Interior.ColorIndex = xlNone
                  End If
               End With
            Next
         End If
         
         'Scenario 2:
         If bL And bH = False Then
            For Each rCell In rCol
               bRed = False
               With rCell
                  If .Value < dLow Then
                     If bCheck And .Offset(0, lOffset).Value = 1 Then
                        bRed = True
                     ElseIf bCheck = False Then bRed = True
                     End If
                  End If
                  If bRed Then
                     .Interior.ColorIndex = 3
                     .Interior.Pattern = xlSolid
                     lRedCount = lRedCount + 1
                  Else
                     .Interior.ColorIndex = xlNone
                  End If
               End With
            Next
         End If
         
         'Scenario 3:
         If bL = False And bH Then
            For Each rCell In rCol
               bRed = False
               With rCell
                  If .Value > dHigh Then
                     If bCheck And .Offset(0, lOffset).Value = 1 Then
                        bRed = True
                     ElseIf bCheck = False Then bRed = True
                     End If
                  End If
                  If bRed Then
                     .Interior.ColorIndex = 3
                     .Interior.Pattern = xlSolid
                     lRedCount = lRedCount + 1
                  Else
                     .Interior.ColorIndex = xlNone
                  End If
               End With
            Next
         End If
      Else
         GoTo Skip
      End If
      .Offset(2, 0).Value = lRedCount
   End With
Skip:
Next

BeforeExit:
Set rMode = Nothing
Set rCol = Nothing
Set rMCell = Nothing
Set rCell = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure FormatCells"
Resume BeforeExit
End Sub

Det var det - hvordan man kan bruge VBA i stedet for Excels betingede formatering og tælle de celler, man gør noget ved.