Макрос Excel для изменения цвета фона

Question

Я работаю над простым макросом Excel, чтобы изменить цвет фона в зависимости от значения ячейки. Это в основном для отображения изображения в Excel. Однако следующий код вызывает сбой Excel без видимой причины.

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

Рабочий лист содержит 400 столбцов и 693 строки. Макрос запускается правильно, но Excel случайно падает в процессе, и я не могу сказать, почему.

Я добавил код обработки ошибок, но ничего не отображается.

Кроме того, есть ли более эффективный способ, чем зацикливание на каждом столбце и строке?

Answer 1

Попробуй это:

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

Основная проблема, я думаю, заключалась в том, что вы перебирали все строки на листе, что может занять много времени и, возможно, привести к сбою книги. Вместо этого я изменил ваш первый цикл For For i = 1 to MaxRows

Помимо этого, я сделал небольшую настройку, чтобы сделать макрос более динамичным и избежать "жестко запрограммированных" чисел, где я мог. Предполагается, что в вашем столбце A содержится наибольшее количество данных, а в строке 1 содержится наибольшее количество данных столбца.

Answer 2

Excel фактически зависал в цикле без возможности обновить свое окно и поэтому выглядел как застрявший.

Решение состоит в том, чтобы вызвать DoEvents в цикле.

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