Looking for Macro Help: Zeroing Out Cells & Color Coding

  • Thread starter Thread starter orangepips
  • Start date Start date
O

orangepips

Any help is appreciated.

I am running into trouble trying to write a Macro that does the
following:

* Affects all workbook tabs (i.e. worksheets).
* Zeros out all numeric constants.
* Color codes the following
* Named cells (gray background)

What I've got so far (see below) gives me the error "1004
Application-defined or object-defined error". I think that it has to do
with not being able to get a proper range reference to loop over cells
on a given worksheet but I am at a loss.

Sub ColorCodeAndZeroOut()
For i = 1 To Worksheets.Count
On Error GoTo ErrorHandler

For Each n In LastCell(Worksheets(i)).Cells

If IsEmpty(n.Name.Name) Then
n.Interior.ColorIndex = 0 'White
Else
n.Interior.ColorIndex = 15 'Gray
End If

If IsNumeric(n) And Not n.HasFormula Then
If n.Value <> 0 Then
n.Value = 0
ProtectedCell:
End If
End If
Next n

ErrorHandler:
If Err = 1005 Then
Resume ProtectedCell
Else
MsgBox Err.Number & " " & Err.Description & " " &
Err.Source

End If

Next i
End Sub

Function LastCell(ws As Worksheet) As Range
Dim LastRow&, LastCol%

' Error-handling is here in case there is not any
' data in the worksheet

On Error Resume Next

With ws

' Find the last real row

LastRow& = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

' Find the last real column

LastCol% = .Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column

End With

' Finally, initialize a Range object variable for
' the last populated row.

Set LastCell = ws.Cells(LastRow&, LastCol%)

End Function
 
Dim sh as Worksheet
Dim rng as Range
dim nme as Name
for each sh in ActiveWorkbook.Worksheets
set rng = Nothing
sh.Cells.Interior.ColorIndex = xlNone
On Error Resume Next
set rng = sh.Cells.SpecialCells(xlConstants,xlNumbers)
On Error goto 0
if not rng is nothing then
rng.Value = 0
end if
Next
For each nme in ActiveWorkbook.Names
set rng = Nothing
On Error Resume Next
set rng = nme.RefersToRange
On Error goto 0
if not rng is nothing then
rng.Interior.ColorIndex = 15
end if
Next
 
Thanks that worked. I owe you a beer if you're ever in Baltimore.
Regards. Matthew Lesko
 
Back
Top