Prevent creating duplicate worksheets in a loop (VBA)

[Retroshift]

Hello,

I have VBA code with an inputbox where you can enter specific years in order to create worksheets containing the months of this year.
Now, if the year is entered twice, then the sub should be exited with the messagebox "This year has already been entered". Anyone has the VBA knowledge to complete the code below accordingly? The line ".Name = MonthName(i, True) & Right(yr, 4)" seems to cause an issue with duplicate years and I would like to prevent this.

Sub AddMonthSheets()
    Dim yr As String
    Dim i As Integer
    Dim rng As Range
      
    yr = InputBox("For which year do you want to create month sheets?", "Enter a year", "e.g. " & Year(Date))
      If (yr) Like "[2-9][0-9][0-9][0-9]" Then
      ElseIf StrPtr(yr) = 0 Then
        Exit Sub
      Else
        MsgBox "Enter a year value between 1999 and 9999"
        Exit Sub
      End If
        
    For i = 1 To 12 Step 1
            Sheets.Add.Move after:=Sheets(Sheets.Count)
            With ActiveSheet
            [SIZE=4].Name = MonthName(i, True) & Right(yr, 4)[/SIZE]
            .Range("B1") = DateSerial(yr, i, 1)
            .Range("B1").NumberFormat = "[$-en-GB]ddd"
            .Range("B1").AutoFill Destination:=Range("B1").Resize(1, Day(DateSerial(yr, i + 1, 1) - 1)), Type:=xlFillDefault
            .Range("B1:AF2").HorizontalAlignment = xlCenter
            .Range("B1:AF2").ColumnWidth = 7
                
            .Range("B2") = DateSerial(yr, i, 1)
            .Range("B2").NumberFormat = "d-mm"
            .Range("B2").AutoFill Destination:=Range("B2").Resize(1, Day(DateSerial(yr, i + 1, 1) - 1)), Type:=xlFillDefault
            End With
                           
    For Each rng In Range("B1").Resize(2, Day(DateSerial(yr, i + 1, 1) - 1))
    If Weekday(rng.Value) = 1 Or Weekday(rng.Value) = 7 Then
    rng.Interior.Color = RGB(8, 200, 26)
    End If
    Next rng
     
    Next i
          
    Sheets(1).Activate
       
End Sub

 

[dmt32]

Hi,
see if this update to your code does what you want

Sub AddMonthSheets()
    Dim i               As Long
    Dim rng             As Range
    Dim yr              As Variant
    Dim DefaultPrompt   As String, msg As String
    
    
    Do
        DefaultPrompt = Chr(10) & Chr(10) & "e.g. " & Year(Date)
        SendKeys "{END}"
        yr = InputBox("For which year Do you want To create month sheets?" & DefaultPrompt, "Enter a year", Year(Date))
        'cancel pressed
        If StrPtr(yr) = 0 Then Exit Sub
    Loop Until (yr) Like "[2-9][0-9][0-9][0-9]"
    
    For i = 1 To 12 Step 1
        'check duplicate sheet(s)
        If Not Evaluate("isref('" & MonthName(i, True) & Right(yr, 4) & "'!A1)") Then
            Sheets.Add.Move after:=Sheets(Sheets.Count)
            
            With ActiveSheet
                
                .Name = MonthName(i, True) & Right(yr, 4)
                .Range("B1") = DateSerial(yr, i, 1)
                .Range("B1").NumberFormat = "[$-en-GB]ddd"
                .Range("B1").AutoFill Destination:=Range("B1").Resize(1, Day(DateSerial(yr, i + 1, 1) - 1)), _
                                      Type:=xlFillDefault
                .Range("B1:AF2").HorizontalAlignment = xlCenter
                .Range("B1:AF2").ColumnWidth = 7
                
                .Range("B2") = DateSerial(yr, i, 1)
                .Range("B2").NumberFormat = "d-mm"
                .Range("B2").AutoFill Destination:=Range("B2").Resize(1, Day(DateSerial(yr, i + 1, 1) - 1)), _
                                      Type:=xlFillDefault
            End With
            
            For Each rng In Range("B1").Resize(2, Day(DateSerial(yr, i + 1, 1) - 1))
                If Weekday(rng.Value) = 1 Or Weekday(rng.Value) = 7 Then
                    rng.Interior.Color = RGB(8, 200, 26)
                End If
            Next rng
        Else
         msg = msg & MonthName(i, True) & Right(yr, 4) & Chr(10)
        End If
    Next i
    
    If Len(msg) > 0 Then MsgBox "The Following Sheets Already Exist" & Chr(10) & msg, 64, "Sheets Exist"
    
    Sheets(1).Activate
    
End Sub

Dave

 

[Retroshift]

Hi Dave,
This neat code seems to work but for some unknown reason its technical wizardry disables my Num Lock key when pressing the macro button. I have a French/Belgium Azerty keyboard and I am using the Numpad to enter the year in the InputBox.

 

[dmt32]

curious

try replacing this line

SendKeys "{END}"

with this

SendKeys "{NUMLOCK}"

Dave

 

[Retroshift]

Still the same result: the numlock key being disabled. What exactly is the function of the SendKeys line?

 

[dmt32]

in this case just enables it - try deleting that line

Dave

 

[Retroshift]

Deleting the line seems to do the trick. The code returns an error when the value 9999 is entered in the inputbox. Is there a way to make it error-proof?

 

[dmt32]

Deleting the line seems to do the trick. The code returns an error when the value 9999 is entered in the inputbox. Is there a way to make it error-proof?

maybe just limit user entry in your like test?

(yr) Like "[2][0-9][0-9][0-9]"

Dave

 

[Retroshift]

Thanks a lot, Dave. It worked like a charm. Marked as solved.
Cheers

 

[dmt32]

welcome - appreciate feedback

Dave