Loop a code thru several worksheets

[Melanie]

I have a code that I have perfected to work, but I cannot find the right
way to have it loop thru several worksheets. My code is as follows:

Sub Update_Row_Colors()

Dim LRow As Integer
Dim LCell As String
Dim LColorCells As String
'Start at row 7
LRow = 7

'Update row colors for the first 1000 rows
While LRow < 1000
LCell = "H" & LRow
'Color will change in columns A to CV
LColorCells = "A" & LRow & ":" & "CV" & LRow

Select Case Left(Range(LCell).Value, 6)

'Set row color to yellow
Case "H"
Range(LColorCells).Interior.ColorIndex = 6
Range(LColorCells).Interior.Pattern = xlSolid

'Set row color to red
Case "C"
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 3
Range(LColorCells).Interior.Pattern = xlSolid

'Set row color to gray
Case "S"
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 15
Range(LColorCells).Interior.Pattern = xlSolid

'Default all other rows to no color
Case Else
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = xlNone

End Select

LRow = LRow + 1
Wend

Range("A1").Select

End Sub

and here's the code i found to loop it, but it only works on the first
worksheet.

Option Explicit

Sub LoopThroughSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets

'** Perform code here **

'E.g.
On Error Resume Next 'Will continue if an error results
ws.Range("A1") = ws.Name

'***********************

Next ws
End Sub

Any help would be much appreciated.

 

[r]

Sub LoopThroughSheets()
Dim ws As Worksheet
Dim sh As Worksheet
Set sh = ActiveSheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets

ws.Select
Call Update_Row_Colors
'** Perform code here **

'E.g.
On Error Resume Next 'Will continue if an error results
ws.Range("A1") = ws.Name

'***********************

Next ws
sh.Select
Application.ScreenUpdating = True
End Sub

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html

 

[r]

or ...

Sub Update_Row_Colors(SH As Worksheet)

Dim LRow As Integer
Dim LCell As String
Dim LColorCells As String
'Start at row 7
LRow = 7

'Update row colors for the first 1000 rows
With SH
While LRow < 1000
LCell = "H" & LRow
'Color will change in columns A to CV
LColorCells = "A" & LRow & ":" & "CV" & LRow

Select Case Left(.Range(LCell).Value, 6)
'Set row color to yellow
Case "H"
.Range(LColorCells).Interior.ColorIndex = 6
.Range(LColorCells).Interior.Pattern = xlSolid

'Set row color to red
Case "C"
'.Rows(LRow & ":" & LRow).Select
.Range(LColorCells).Interior.ColorIndex = 3
.Range(LColorCells).Interior.Pattern = xlSolid

'Set row color to gray
Case "S"
'.Rows(LRow & ":" & LRow).Select
.Range(LColorCells).Interior.ColorIndex = 15
.Range(LColorCells).Interior.Pattern = xlSolid

'Default all other rows to no color
Case Else
'.Rows(LRow & ":" & LRow).Select
.Range(LColorCells).Interior.ColorIndex = xlNone

End Select

LRow = LRow + 1
Wend

End With
End Sub




Sub LoopThroughSheets()
Dim ws As Worksheet
Dim SH As Worksheet
Set SH = ActiveSheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets

Update_Row_Colors ws
'** Perform code here **

'E.g.
On Error Resume Next 'Will continue if an error results
ws.Range("A1") = ws.Name

'***********************

Next ws
SH.Select
Application.ScreenUpdating = True
End Sub

regards
r


--
Come e dove incollare il codice:
http://www.rondebruin.nl/code.htm

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html