How to Loop through code

[Eurekaonide]

Hi Please can you help me expand this code range and loop?

I have 2 worksheets one is called Compare and one is called Directorate Resources_2
On the Compare I have a range of cells/columns/rows that are returning either 0 or 1
If it sees a 1 I want the cell in Directorate Resources_2 to be coloured Purple and Yellow text. (I have tried this through conditional formatting but because there are so many different things happening between the sheets before this step the conditional formatting keeps changing its rows etc even with $ in front)
So I feel best if I hard code it in.

I have the below which works fine but I need it to go down the rows which I dont know how long the data set will be and also cover the following columns:
Compare Sheet Columns are AP2 to BA
Directorate Resources_2 sheet Columns Q4 to AB

can you advise on the best way to loop through this formula/conditional formatting please?

Sub Test2()
Sheets("compare").Select

Range("AP2").Select

If Value = 1 Then
Sheets("Directorate Resources_2").Activate
Range("Q4").Select

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 10498160
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16711681
.TintAndShade = 0
End With
Selection.Font.Bold = True
End If

 

[dreid1011]

Give this a try:

Sub Test2()
Dim lRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range

'Set worksheet variables
Set ws1 = Sheets("Compare")
Set ws2 = Sheets("Directorate Resources_2")

'Identify last used row in range AP:BA on sheet Compare
lRow = ws1.Range("AP" & Rows.Count).End(xlUp).Row

'Loop through each cell in the used range on sheet Compare and check values
'then format corresponding cells on sheet Directorate Resources_2 as necessary
For Each c In ws1.Range("AP2:BA" & lRow)
    If c.Value = 1 Then
        With ws2.Cells(c.Row + 2, c.Column - 25)
            .Interior.Pattern = xlSolid
            .Interior.PatternColorIndex = xlAutomatic
            .Interior.Color = 10498160
            .Interior.TintAndShade = 0
            .Interior.PatternTintAndShade = 0
            .Font.Color = -16711681
            .Font.TintAndShade = 0
            .Font.Bold = True
        End With
    End If
Next c
End Sub

 

[Eurekaonide]

Give this a try:

Sub Test2()
Dim lRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range

'Set worksheet variables
Set ws1 = Sheets("Compare")
Set ws2 = Sheets("Directorate Resources_2")

'Identify last used row in range AP:BA on sheet Compare
lRow = ws1.Range("AP" & Rows.Count).End(xlUp).Row

'Loop through each cell in the used range on sheet Compare and check values
'then format corresponding cells on sheet Directorate Resources_2 as necessary
For Each c In ws1.Range("AP2:BA" & lRow)
    If c.Value = 1 Then
        With ws2.Cells(c.Row + 2, c.Column - 25)
            .Interior.Pattern = xlSolid
            .Interior.PatternColorIndex = xlAutomatic
            .Interior.Color = 10498160
            .Interior.TintAndShade = 0
            .Interior.PatternTintAndShade = 0
            .Font.Color = -16711681
            .Font.TintAndShade = 0
            .Font.Bold = True
        End With
    End If
Next c
End Sub

Thank you so so much this worked great - Much appreciated

 

[dreid1011]

You're welcome, and happy to help.