KyleJackMorrison
Board Regular
- Joined
- Dec 3, 2013
- Messages
- 107
- Office Version
- 365
- 2021
- 2019
- Platform
- Windows
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?
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.
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?
Code:
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.