Macro find calendar and paste in range when new year starts

[bbqsmokeman]

Have workbook with approx 30 sheets each have person's name and 2 calendar years (2016 at range L13:AH48) and (2015 at range AJ13:BF48) and Summary has same calendars at M8:AI43 -2016 calendar and 2015 calendar at AK8:BG43. I have a calendar sheet created with 12 month calendars till 2021 for now (examples- 2019 calendar at AX3:BT38; 2018 calendar at BV3:CR38) the newer calendars are closer to A8 range and older calendars are further into the worksheet. I built code to move 2016 and 2015 calendars over and delete 2015 calendar but am unable to figure out how to have the macro find calendar 2017 on calendar sheet and place it where the 2016 was. End result is to have 2 calendars each sheet (one current year and the other previous year). I built a macro to accomplish the move, delete and restore legend but I am left with a blank range that I want to add this years calendar into. I have on each sheet cell F1 with =today() and would like to know if the macro can change every sheet when next year arrives or does it have to be done manually on each sheet. I have a summary sheet also that has the same 2 calendars but at slightly different locations - 2016 calendar at M8: AI43 and 2015 calendar at AK8: BG43.
Here is the code I made to move the calendars over (not coded for Summary since has different ranges) but have code working on one reps worksheet except unable to figure out code to find the calendar for year we are in and place in the empty range). The code I have works great at this point but is there anything easier that can look at all sheets regardless of location and when next year arrives click a button and all sheets calendars move and delete the older calendar and keep current and last year calendar.

Sub TeamSliderAndClean()

    Columns("L:AI").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.ColumnWidth = 2.29
    Range("AJ1:BH6").Select
    Selection.Cut
    Range("L1").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 14
    ActiveWindow.ScrollColumn = 23
    ActiveWindow.ScrollColumn = 24
    ActiveWindow.ScrollColumn = 25
    Columns("BH:CD").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.ScrollColumn = 24
    ActiveWindow.ScrollColumn = 23
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollColumn = 2
    Range("L1").Select
End Sub

 

[Nebu]

Hi:

Upload a sample file.

Thanks

 

[Monty]

Hey bbsmokeman...

Interesting question...can we have sample file please to help.

 

[bbqsmokeman]

Hi Nebu,

Here is a sample file. Sorry I had to strip it down to only a few names from 30 and remove all the formatting etc but the file was too large to upload.
Thanks

 

[Nebu]

Hi:

Use the following code:

Sub test()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim rng As Range, fnd As Range

With Sheet6
    j& = .Cells(5, Columns.Count).End(xlToLeft).Column
    Set rng = .Range(.Cells(3, 1), .Cells(3, j))
End With

cy& = Year(Date)
py& = Year(Date) - 1

For Each ws In Worksheets
    If ws.Name <> "2016 - 2021 Calendar Replace" And ws.Name <> "Summary" Then
        Set fnd = rng.Find(What:=cy)
            With Sheet6
                .Range(.Cells(3, fnd.Column - 9), .Cells(38, fnd.Column + 13)).Copy
                ws.Range("L13").PasteSpecial
            End With
        Set fnd = rng.Find(What:=py)
            With Sheet6
                .Range(.Cells(3, fnd.Column - 9), .Cells(38, fnd.Column + 13)).Copy
                ws.Range("AJ13").PasteSpecial
            End With
        Application.CutCopyMode = False
    End If
Next
Application.ScreenUpdating = True
End Sub

Thanks

 

[bbqsmokeman]

Nebu

You truly are an excel ninja, wow! that worked fantastic!!
That is impressive how it does it for all the sheets so fast!!
I do have a question though and my apologies for not mentioning it earlier. I forgot to mention that on the calendars (2016) on each sheet they usually have cells color coded that I would need to carry over when it moves into the 2015 position. Is that hard to add the code into it?

 

[Nebu]

Hi:
Modified code:

Sub test()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim rng As Range, fnd As Range

With Sheet6
    j& = .Cells(5, Columns.Count).End(xlToLeft).Column
    Set rng = .Range(.Cells(3, 1), .Cells(3, j))
End With

cy& = Year(Date)
py& = Year(Date) - 1

For Each ws In Worksheets
    If ws.Name <> "2016 - 2021 Calendar Replace" And ws.Name <> "Summary" Then
        Set fnd = rng.Find(What:=py)
            With Sheet6
                .Range(.Cells(3, fnd.Column - 9), .Cells(38, fnd.Column + 13)).Copy
                ws.Range("AJ13").PasteSpecial
            End With
           
            ws.Range("L15:AH48").Copy
            ws.Range("AJ15").PasteSpecial Paste:=xlPasteFormats

        Set fnd = rng.Find(What:=cy)
            With Sheet6
                .Range(.Cells(3, fnd.Column - 9), .Cells(38, fnd.Column + 13)).Copy
                ws.Range("L13").PasteSpecial
            End With
        Application.CutCopyMode = False
    End If
Next
Application.ScreenUpdating = True
End Sub

Thanks

 

[bbqsmokeman]

Nebu,
You are a master!!!
Thank you very much!
I am one who is still learning coding like what you've done and started with simpler code for macros and you have impressed me immensely and makes me want to learn more and more! I am going to take the time to learn and understand what the code means so I can develop myself from your knowledge and expertise!

thank you