Macro do Excel para alterar a cor de fundo

Question

Estou trabalhando em uma macro simples do Excel para alterar a cor de segundo plano, dependendo do valor da célula. Isso é basicamente para exibir uma imagem no Excel. No entanto, o código a seguir faz com que o Excel trave sem motivo aparente.

Option Explicit


Sub SetBgColor()
    On Error GoTo ErrHandler

    Dim Data As Worksheet
    Set Data = Sheets("Data")

    Dim i As Long
    Dim j As Long

    Dim MaxRows As Long
    MaxRows = 693

    Dim MaxCols As Long
    MaxCols = 400


    Dim CellVal As Integer
    For i = 1 To Rows.Count
        For j = 1 To MaxCols
            CellVal = Data.Cells(i, j).Value Mod 255

            If i Mod 3 = 0 Then
                Data.Cells(i, j).Interior.Color = RGB(0, 0, CellVal)
            ElseIf i Mod 3 = 1 Then
                Data.Cells(i, j).Interior.Color = RGB(CellVal, 0, 0)
            ElseIf i Mod 3 = 2 Then
                Data.Cells(i, j).Interior.Color = RGB(0, CellVal, 0)
            End If
        Next j
    Next i

ErrHandler:
Dim Msg As String

If Err.Number <> 0 Then
    Msg = "Error #" & Str(Err.Number) & " generated by " & Err.Source & Chr(13) _
        & "Error Line: " & Erl & Chr(13) _
        & Chr(13) _
        & Err.Description

    MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If

End Sub

A planilha contém 400 colunas e 693 linhas. A macro é iniciada corretamente, mas o Excel falha aleatoriamente no processo e não posso dizer por quê.

Adicionei o código de tratamento de erros, mas nada está sendo exibido.

Além disso, existe uma maneira mais eficiente de fazer um loop sobre cada coluna e linha?

    

Answer 1

Tente isto:

Sub SetBgColor()
On Error GoTo ErrHandler

Dim Data    As Worksheet
Set Data = Sheets("Data")

Dim i       As Long
Dim j       As Long

With Data
    Dim MaxRows As Long
    MaxRows = .Cells(.Rows.Count, 1).End(xlUp).Row    ' assuming Column A (1) has the most data

    Dim MaxCols As Long
    MaxCols = .Cells(1, .Columns.Count).End(xlToLeft).Column    ' assuming your row 1 has the most column data

    Dim CellVal As Integer
    For i = 1 To MaxRows
        For j = 1 To MaxCols
            CellVal = .Cells(i, j).Value Mod 255
            If i Mod 3 = 0 Then
                .Cells(i, j).Interior.Color = RGB(0, 0, CellVal)
            ElseIf i Mod 3 = 1 Then
                .Cells(i, j).Interior.Color = RGB(CellVal, 0, 0)
            ElseIf i Mod 3 = 2 Then
                .Cells(i, j).Interior.Color = RGB(0, CellVal, 0)
            End If
        Next j
    Next i
End With                     'Data

Exit Sub

ErrHandler:
Dim Msg     As String

If Err.Number <> 0 Then
    Msg = "Error #" & Str(Err.Number) & " generated by " & Err.Source & Chr(13) _
          & "Error Line: " & Erl & Chr(13) _
          & Chr(13) _
          & Err.Description

    MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If

End Sub

A questão principal, eu acho, é que você estava passando por todas as linhas na planilha, o que pode levar muito tempo e, possivelmente, travar a pasta de trabalho. Em vez disso, alterei seu primeiro For loop para For i = 1 to MaxRows .

Além disso, fiz alguns ajustes para tornar a macro mais dinâmica e evitar números "codificados" onde eu poderia. Isso pressupõe que sua coluna A tenha mais dados e a linha 1 inclua a maioria dos dados da coluna.

    

Answer 2

O Excel estava, de fato, congelando no ciclo, sem nenhuma maneira de atualizar sua janela e, portanto, parecendo estar presa.

A solução é chamar DoEvents no loop.

For i = 1 To MaxRows
    For j = 1 To MaxCols
        CellVal = .Cells(i, j).Value Mod 255
        If i Mod 3 = 0 Then
            .Cells(i, j).Interior.Color = RGB(0, 0, CellVal)
        ElseIf i Mod 3 = 1 Then
            .Cells(i, j).Interior.Color = RGB(CellVal, 0, 0)
        ElseIf i Mod 3 = 2 Then
            .Cells(i, j).Interior.Color = RGB(0, CellVal, 0)
        End If
    Next j
    DoEvents
Next i