Simplify and shorten my code to search by colour

[KyleJackMorrison]

Hello,

So I have a code which upon running it searches set cells for the colour and then counts that colour. As i need this to run over a large amount of data i don't want to have a huge copy and pasted code where i just change the cell address and the paste address. Is there a way i can simplify this?

Sub Manning()
If Weekday(Date) = vbTuesday Then
Sheets("Calendar").Select
Sheets("Calendar").Unprotect Password:="PASSWORD"
ActiveSheet.Range("J23").Select
ActiveSheet.AutoFilterMode = False
ActiveSheet.Range(ActiveCell, Cells(ActiveCell.Row + 130, ActiveCell.Column)).AutoFilter _
Field:=1, Criteria1:=RGB(255, 102, 0), Operator:=xlFilterCellColor
ActiveSheet.Range("D4").Select
ActiveSheet.Range("D4").Formula = "=Subtotal(3,D24:D130)"
ActiveSheet.Range("D4").Copy
Worksheets("Manning").Range("A3").PasteSpecial xlPasteValues
ActiveSheet.AutoFilterMode = False


Sheets("Calendar").Select
ActiveSheet.Range("q23").Select
ActiveSheet.AutoFilterMode = False
ActiveSheet.Range(ActiveCell, Cells(ActiveCell.Row + 130, ActiveCell.Column)).AutoFilter _
Field:=1, Criteria1:=RGB(255, 102, 0), Operator:=xlFilterCellColor
ActiveSheet.Range("D4").Select
ActiveSheet.Range("D4").Formula = "=Subtotal(3,D24:D130)"
ActiveSheet.Range("D4").Copy
Worksheets("Manning").Range("b3").PasteSpecial xlPasteValues
ActiveSheet.AutoFilterMode = False


Sheets("Calendar").Select
ActiveSheet.Range("x23").Select
ActiveSheet.AutoFilterMode = False
ActiveSheet.Range(ActiveCell, Cells(ActiveCell.Row + 130, ActiveCell.Column)).AutoFilter _
Field:=1, Criteria1:=RGB(255, 102, 0), Operator:=xlFilterCellColor
ActiveSheet.Range("D4").Select
ActiveSheet.Range("D4").Formula = "=Subtotal(3,D24:D130)"
ActiveSheet.Range("D4").Copy
Worksheets("Manning").Range("c3").PasteSpecial xlPasteValues
ActiveSheet.AutoFilterMode = False


Sheets("Manning").Select
MsgBox "Done"
Else
MsgBox "Error. This can only be run on a Tuesday"
End If
End Sub

As you can see the first part searches cell "J23 - J23 + 130". then pastes the result of the count to cell "A3" on a different sheet.
Then the next "Q23 - Q23 + 130". then pastes it to cell "B3" on another sheet.
and so on and so on. All the way up to "NJ23"
"J23, Q23, x23"...etc is every 7 cells (Every Tuesday).
A3, B3, C3... ete is every next cell.

Many thanks in advance.

 

[Fluff]

How about

Sub KyleJackMorrison()
   Dim Clm As Long, Clm2 As Long
   If Weekday(Date) = vbTuesday Then
      With Sheets("Calendar")
         .Unprotect Password:="PASSWORD"
         For Clm = 10 To 374 Step 7
         Clm2 = Clm2 + 1
         If .AutoFilterMode Then .AutoFilterMode = False
         .Range(Cells(23, Clm), Cells(153, Clm)).AutoFilter 1, RGB(255, 102, 0), xlFilterCellColor
         .Range("D4").Formula = "=Subtotal(3,D24:D130)"
         Worksheets("Manning").Cells(3, Clm2).Value = .Range("D4").Value
         .AutoFilterMode = False
      End With
      Sheets("Manning").Select
      MsgBox "Done"
   Else
      MsgBox "Error. This can only be run on a Tuesday"
   End If
End Sub

 

[KyleJackMorrison]

Just got a Compile Error

[COLOR=#ff0000]End With[/COLOR]

End with without with

 

[Fluff]

Oops,for the line in blue

Sub KyleJackMorrison()
   Dim Clm As Long, Clm2 As Long
   If Weekday(Date) = vbTuesday Then
      With Sheets("Calendar")
         .Unprotect Password:="PASSWORD"
         For Clm = 10 To 200 Step 7
            Clm2 = Clm2 + 1
            If .AutoFilterMode Then .AutoFilterMode = False
            .Range(Cells(23, Clm), Cells(153, Clm)).AutoFilter 1, RGB(255, 102, 0), xlFilterCellColor
            .Range("D4").Formula = "=Subtotal(3,D24:D130)"
            Worksheets("Manning").Cells(3, Clm2).Value = .Range("D4").Value
            .AutoFilterMode = False
         [COLOR=#0000ff]Next Clm[/COLOR]
      End With
      Sheets("Manning").Select
      MsgBox "Done"
   Else
      MsgBox "Error. This can only be run on a Tuesday"
   End If
End Sub

 

[KyleJackMorrison]

Perfection. Thank you Mr Fluff

 

[Fluff]

You're welcome & thanks for the feedback