I have a vba code that I need help add or change code

%3CLINGO-SUB%20id%3D%22lingo-sub-2741810%22%20slang%3D%22en-US%22%3ERe%3A%20I%20have%20a%20vba%20code%20that%20I%20need%20help%20add%20or%20change%20code%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2741810%22%20slang%3D%22en-US%22%3EThe%20code%20is%20already%20creating%201-18%20worksheets%2C%20one%20worksheet%20for%20each%20unique%20week%20in%20column%20A%20on%20the%20Yearly%20Schedule%20worksheet.%20For%20me%2C%20it%20is%20working%20as%20desired.%20Am%20I%20missing%20something%20here%3F%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2741606%22%20slang%3D%22en-US%22%3EI%20have%20a%20vba%20code%20that%20I%20need%20help%20add%20or%20change%20code%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2741606%22%20slang%3D%22en-US%22%3E%3CP%3EI%20have%20yearly%20schedule.%20When%20you%20press%20button%20that%20will%20creating%201-17%20worksheets.%20I%20need%20to%20have%20to%20create%201-18%20worksheets.%20I%20need%20help%20with%20vba%20code%20to%20make%20code%20to%20work%20what%20I%20want.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3EPrivate%20Sub%20CREATING_WEEKLY_SCHEDULES_Click()%20Dim%20LastRow%20As%20Integer%2C%20rngUniqueWeeks%20As%20Range%2C%20rngWeeks%20As%20Range%20Application.ScreenUpdating%20%3D%20False%20With%20Worksheets(%22Yearly%20Schedule%22)%20LastRow%20%3D%20.Range(%22A%22%20%26amp%3B%20Rows.Count).End(xlUp).Row%20.Range(%22A1%3AA%22%20%26amp%3B%20LastRow).AdvancedFilter%20xlFilterInPlace%2C%20Unique%3A%3DTrue%20Set%20rngUniqueWeeks%20%3D%20.Range(%22A2%3AA%22%20%26amp%3B%20LastRow).SpecialCells(xlCellTypeVisible)%20For%20Each%20rngWeeks%20In%20rngUniqueWeeks%20.Range(%22A1%3AA%22%20%26amp%3B%20LastRow).AutoFilter%201%2C%20rngWeeks%20If%20Evaluate(%22ISREF('%22%20%26amp%3B%20rngWeeks.Value%20%26amp%3B%20%22'!A1)%22)%20Then%20'Test%20if%20worksheet%20name%20exists%20'Copy%20to%20existing%20sheet%20.Range(%22A2%3AA%22%20%26amp%3B%20LastRow).EntireRow.Copy%20_%20Sheets(rngWeeks.Value).Range(%22A%22%20%26amp%3B%20Rows.Count).End(xlUp).Offset(1)%20Else%20'Create%20Weeks%20sheet%20Sheets.Add(After%3A%3DSheets(Sheets.Count)).Name%20%3D%20rngWeeks%20.AutoFilter.Range.EntireRow.Copy%20Destination%3A%3DActiveSheet.Range(%22A1%22)%20End%20If%20Next%20rngWeeks%20.Select%20.AutoFilterMode%20%3D%20False%20End%20With%20Application.ScreenUpdating%20%3D%20True%20MsgBox%20%22Copy%20complete.%20%22%2C%20%2C%20%22Split%20Records%20By%20Weeks%22%20End%20Sub%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-2741606%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EOffice%20365%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E
Contributor

I have yearly schedule. When you press button that will creating 1-17 worksheets. I need to have to create 1-18 worksheets. I need help with vba code to make code to work what I want.

 

 

 

 

 

Private Sub CREATING_WEEKLY_SCHEDULES_Click()
 Dim LastRow As Integer, rngUniqueWeeks As Range, rngWeeks As Range
    Application.ScreenUpdating = False
    With Worksheets("Yearly Schedule")
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:A" & LastRow).AdvancedFilter xlFilterInPlace, Unique:=True
        Set rngUniqueWeeks = .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
        For Each rngWeeks In rngUniqueWeeks
            .Range("A1:A" & LastRow).AutoFilter 1, rngWeeks
            If Evaluate("ISREF('" & rngWeeks.Value & "'!A1)") Then  'Test if worksheet name exists
                'Copy to existing sheet
                .Range("A2:A" & LastRow).EntireRow.Copy _
                    Sheets(rngWeeks.Value).Range("A" & Rows.Count).End(xlUp).Offset(1)
            Else
                'Create Weeks sheet
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = rngWeeks
                .AutoFilter.Range.EntireRow.Copy Destination:=ActiveSheet.Range("A1")
            End If
        Next rngWeeks
        .Select
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
    MsgBox "Copy complete. ", , "Split Records By Weeks"
End Sub

 

 

1 Reply
The code is already creating 1-18 worksheets, one worksheet for each unique week in column A on the Yearly Schedule worksheet. For me, it is working as desired. Am I missing something here?