« Paint Custom Color Excel Macro | Main | Monsters, Inc. »

October 08, 2002

Repaint Cells Excel Macro

This Excel Macro will go through a worksheet cell by cell and color any cell that is enclosed in borders (any type as long as it is on all four sides) the same color that column A of that row is colored. This is helpful for maintaining alternating lines and complex patterns. It does run VERY SLOWLY. But it will only take 20 seconds to update an entire sheet, and that's still alot faster than I can do it. The more comlpex the sheet, the better this is.

IMPORTANT NOTE: This macro does two things that you need to be aware of:

  1. It saves the spreadsheet before running the macro (I am paranoid about losing work.
  2. It turns of automatic calculation off while painting and then turns it on again.
[tip!] Do not use this while in page break view. 

Sub RepaintCells()
Dim ws As Worksheet
Dim rowMax, cellMax, cellColor, r, c As Long
Set ws = ActiveSheet
rowMax = ws.UsedRange.Rows.Count
colMax = ws.UsedRange.Columns.Count
Application.Calculation = xlCalculationManual

Application.StatusBar = "Saving Worksheet..."
ActiveWorkbook.Save
For r = 1 To rowMax
    Application.StatusBar = "Painting Row " & r
    For c = 1 To colMax
        Application.StatusBar = "Painting Cell( " & r & ", " & c & ")"
        If c = 1 Then
            cellColor = ws.Cells(r, c).Interior.ColorIndex
        Else
            With ws.Cells(r, c)
                If .Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone And _
                   .Borders(xlEdgeTop).LineStyle <> xlLineStyleNone And _
                   .Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone And _
                   .Borders(xlEdgeRight).LineStyle <> xlLineStyleNone Then
                      .Interior.ColorIndex = cellColor
                End If
            End With
        End If
    Next
    DoEvents
Next
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = "Repaint complete."

End Sub

Posted by Chris at October 8, 2002 04:12 PM

Subscribe to this entry:   Email address:   

Trackback Pings

TrackBack URL for this entry:
http://www.christulino.com/cgi-bin/mt/mt-tb.cgi/31

Comments