VBA to check if worksheet exists

bdt

Board Regular
Joined
Oct 3, 2024
Messages
53
Office Version
  1. 2019
Platform
  1. Windows
Hi all.
I have long piece of code, part of which copies a worksheet "ABACUS" and renames it W.E.dd.mm.yy. What I would like, is to able to check if the intended renamed worksheet exists, if it does show a meesage box and end the code, otherwise continue the code.
the piece of code I have to copy and rename the sheet is,

VBA Code:
'copy and save worksheet with name format W.E.dd.mm.yy
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")

The entire code is,

VBA Code:
Public Sub CopySheetAndRenamePredefined()

    'check date format
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim response As String
    For Each ws In Sheets
        If ws.Range("B2") <> "" And ws.Range("C2") = "" Then
        Do
            response = InputBox("Input date in format **/**/**")
            If response <> "" Then
            ws.Range("C2") = response
            Exit Do
            ElseIf response = "" Then
            MsgBox ("You must enter date in format **/**/**")

        Else: Exit Do
        End If
    Loop
    
    End If
    Next ws
    Application.ScreenUpdating = True
    
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim dte As Date
    Dim writeCel As Range

    ' determine where to start
    With Sheets("OVERTIME")
    Set writeCel = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
    End With

    With ActiveSheet
    '-----SUNDAY-----
    'add overtime and absence sunday
    dte = .Range("M2").Value
    arr1 = .Range("AI21:AI32").Value
    arr2 = .Range("CY21:CY32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel = dte
    writeCel.Offset(0, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----MONDAY-----
    'add overtime and absence monday
    dte = .Range("AC2").Value
    arr1 = .Range("AK21:AK32").Value
    arr2 = .Range("DA21:DA32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(1) = dte
    writeCel.Offset(1, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
    '-----TUESDAY-----
    'add overtime and absence tuesday
    dte = .Range("AS2").Value
    arr1 = .Range("AM21:AM32").Value
    arr2 = .Range("DC21:DC32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(2) = dte
    writeCel.Offset(2, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
    '-----WEDNESDAY-----
    'add overtime and absence wednesday
    dte = .Range("BI2").Value
    arr1 = .Range("AO21:AO32").Value
    arr2 = .Range("DE21:DE32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(3) = dte
    writeCel.Offset(3, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----THURSDAY-----
    'add overtime and absence thursday
    dte = .Range("BY2").Value
    arr1 = .Range("AQ21:AQ32").Value
    arr2 = .Range("DG21:DG32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(4) = dte
    writeCel.Offset(4, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----FRIDAY-----
    'add overtime and absence friday
    dte = .Range("CO2").Value
    arr1 = .Range("AS21:AS32").Value
    arr2 = .Range("DI21:DI32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(5) = dte
    writeCel.Offset(5, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----SATURDAY-----
    'add overtime saturday no absence
    dte = .Range("DE2").Value
    arr1 = .Range("AU21:AU32").Value
    ' write to sheet and clear array
    writeCel.Offset(6) = dte
    writeCel.Offset(6, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    End With
 
 
    Dim frstCel As Range
    Dim fillRng As Range
    
    '-----For formulas and/or under lining-------
    writerow = writeCel.Offset(6, 1).Row
    With Sheets("OVERTIME")
   
        'Debug.Print Application.CountIf(.Range("B10:B" & writeRow), "Sat") Mod 4
        If Application.CountIf(.Range("B10:B" & writerow), "Sat") Mod 4 = 0 Then
            .Range("N" & writerow).FormulaR1C1 = "=SUM(R[-27]C[-11]:RC[-11])"
            .Range("N" & writerow).AutoFill Destination:=.Range("N" & writerow).Resize(, 11)
            .Range("N" & writerow).Resize(, 11).HorizontalAlignment = xlCenter
            With .Range("A" & writerow & ":X" & writerow).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
        Else
            With .Range("A" & writerow & ":X" & writerow).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End If
    End With
    

      
    'copy and save worksheet with name format W.E.dd.mm.yy
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")
    
    
    'delete save button add save changes button
    ActiveSheet.Shapes("Button 1").Delete
    ActiveSheet.Buttons.Add(75, 150, 150, 100).Select
    With Selection
    .Name = "New Button"
    .OnAction = "Button3_Click"
    .Text = "SAVE CHANGES"
    .Font.Size = 24
    .Font.Bold = True
    ActiveSheet.Range("D5").Select
    End With
  
    'ABACUS clear cells and reset tasks
    Worksheets("ABACUS").Activate
    Range("D5:DK17").ClearContents
    Range("CY22:DJ32").ClearContents
    Range("C2").ClearContents
    Range("BP22:CE33").ClearContents
    Range("BE22:BV32").ClearContents
    Range("E3,G3,I3,K3,M3,O3,Q3,S3,U3,W3,Y3,AA3,AC3,AE3,AG3,AI3,AK3,AM3,AO3,AQ3,AS3,AU3,AW3,AY3,BA3,BC3,BE3,BG3,BI3,BK3,BM3,BO3").ClearContents
    Range("BQ3,BS3,BU3,BW3,BY3,CA3,CC3,CE3,CG3,CI3,CK3,CM3,CO3,CQ3,CS3,CU3,CW3,CY3,DA3,DC3,DE3,DG3,DI3,DK3").ClearContents
    [B25] = Range("DM2").Value
    [B26] = Range("DM2").Value
    [B27] = Range("DM2").Value
    [B28] = Range("DM2").Value
    [B29] = Range("DM2").Value
    [B30] = Range("DM2").Value
    [B31] = Range("DM2").Value
    [B32] = Range("DM2").Value
    
    End Sub

Some of you guys will have gathered my understanding of VBA is extremely limited, so I'd be very grateful for any assistance with this. 🤞
Many thanks
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Something like this for that section:

Edit: Nvm, that will keep looping as you add sheets and makes an extra unnecessary copy.

VBA Code:
Dim sht As Worksheet
Dim shtName As String

shtName = "W.E." & Format(Range("C2").Value, "dd.mm.yy")

Debug.Print shtName
For Each sht In Worksheets
    If sht.Name = shtName Then
        MsgBox "Sheet already exists!", vbCritical, "Sheet Exists"
        Exit Sub
    Else
        ActiveSheet.Copy After:=Worksheets("OVERTIME")
        ActiveSheet.Name = shtName
    End If
Next sht
This works better:
VBA Code:
Dim sht As Worksheet
Dim shtName As String
Dim shtCount As Long

shtName = "W.E." & Format(Range("C2").Value, "dd.mm.yy")
shtCount = 0

For Each sht In Worksheets
    If sht.Name = shtName Then
        shtCount = shtCount + 1
    End If
Next sht

If shtCount > 0 Then
    MsgBox "Sheet already exists!", vbCritical, "Sheet Exists"
    Exit Sub
Else
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = shtName
End If
 
Last edited:
  • Like
Reactions: bdt
Upvote 0
VBA Code:
    Dim newWS As Worksheet
    
On Error Resume Next    'suppress error notification
Set newWS = Sheets("W.E." & Format(Range("C2").Value, "dd.mm.yy"))
On Error GoTo 0         're-enable error notification

If newWS Is Nothing Then    'it doesn't exist
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")
Else
    MsgBox " That worksheet already exists"
    Exit Sub
End If
 
Upvote 0
Solution
Hi all.
I have long piece of code, part of which copies a worksheet "ABACUS" and renames it W.E.dd.mm.yy. What I would like, is to able to check if the intended renamed worksheet exists, if it does show a meesage box and end the code, otherwise continue the code.
the piece of code I have to copy and rename the sheet is,

VBA Code:
'copy and save worksheet with name format W.E.dd.mm.yy
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")

The entire code is,

VBA Code:
Public Sub CopySheetAndRenamePredefined()

    'check date format
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim response As String
    For Each ws In Sheets
        If ws.Range("B2") <> "" And ws.Range("C2") = "" Then
        Do
            response = InputBox("Input date in format **/**/**")
            If response <> "" Then
            ws.Range("C2") = response
            Exit Do
            ElseIf response = "" Then
            MsgBox ("You must enter date in format **/**/**")

        Else: Exit Do
        End If
    Loop
   
    End If
    Next ws
    Application.ScreenUpdating = True
   
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim dte As Date
    Dim writeCel As Range

    ' determine where to start
    With Sheets("OVERTIME")
    Set writeCel = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
    End With

    With ActiveSheet
    '-----SUNDAY-----
    'add overtime and absence sunday
    dte = .Range("M2").Value
    arr1 = .Range("AI21:AI32").Value
    arr2 = .Range("CY21:CY32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel = dte
    writeCel.Offset(0, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----MONDAY-----
    'add overtime and absence monday
    dte = .Range("AC2").Value
    arr1 = .Range("AK21:AK32").Value
    arr2 = .Range("DA21:DA32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(1) = dte
    writeCel.Offset(1, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
   
    '-----TUESDAY-----
    'add overtime and absence tuesday
    dte = .Range("AS2").Value
    arr1 = .Range("AM21:AM32").Value
    arr2 = .Range("DC21:DC32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(2) = dte
    writeCel.Offset(2, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
   
    '-----WEDNESDAY-----
    'add overtime and absence wednesday
    dte = .Range("BI2").Value
    arr1 = .Range("AO21:AO32").Value
    arr2 = .Range("DE21:DE32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(3) = dte
    writeCel.Offset(3, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----THURSDAY-----
    'add overtime and absence thursday
    dte = .Range("BY2").Value
    arr1 = .Range("AQ21:AQ32").Value
    arr2 = .Range("DG21:DG32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(4) = dte
    writeCel.Offset(4, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----FRIDAY-----
    'add overtime and absence friday
    dte = .Range("CO2").Value
    arr1 = .Range("AS21:AS32").Value
    arr2 = .Range("DI21:DI32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(5) = dte
    writeCel.Offset(5, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

    '-----SATURDAY-----
    'add overtime saturday no absence
    dte = .Range("DE2").Value
    arr1 = .Range("AU21:AU32").Value
    ' write to sheet and clear array
    writeCel.Offset(6) = dte
    writeCel.Offset(6, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    End With
 
 
    Dim frstCel As Range
    Dim fillRng As Range
   
    '-----For formulas and/or under lining-------
    writerow = writeCel.Offset(6, 1).Row
    With Sheets("OVERTIME")
  
        'Debug.Print Application.CountIf(.Range("B10:B" & writeRow), "Sat") Mod 4
        If Application.CountIf(.Range("B10:B" & writerow), "Sat") Mod 4 = 0 Then
            .Range("N" & writerow).FormulaR1C1 = "=SUM(R[-27]C[-11]:RC[-11])"
            .Range("N" & writerow).AutoFill Destination:=.Range("N" & writerow).Resize(, 11)
            .Range("N" & writerow).Resize(, 11).HorizontalAlignment = xlCenter
            With .Range("A" & writerow & ":X" & writerow).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
        Else
            With .Range("A" & writerow & ":X" & writerow).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End If
    End With
   

     
    'copy and save worksheet with name format W.E.dd.mm.yy
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")
   
   
    'delete save button add save changes button
    ActiveSheet.Shapes("Button 1").Delete
    ActiveSheet.Buttons.Add(75, 150, 150, 100).Select
    With Selection
    .Name = "New Button"
    .OnAction = "Button3_Click"
    .Text = "SAVE CHANGES"
    .Font.Size = 24
    .Font.Bold = True
    ActiveSheet.Range("D5").Select
    End With
 
    'ABACUS clear cells and reset tasks
    Worksheets("ABACUS").Activate
    Range("D5:DK17").ClearContents
    Range("CY22:DJ32").ClearContents
    Range("C2").ClearContents
    Range("BP22:CE33").ClearContents
    Range("BE22:BV32").ClearContents
    Range("E3,G3,I3,K3,M3,O3,Q3,S3,U3,W3,Y3,AA3,AC3,AE3,AG3,AI3,AK3,AM3,AO3,AQ3,AS3,AU3,AW3,AY3,BA3,BC3,BE3,BG3,BI3,BK3,BM3,BO3").ClearContents
    Range("BQ3,BS3,BU3,BW3,BY3,CA3,CC3,CE3,CG3,CI3,CK3,CM3,CO3,CQ3,CS3,CU3,CW3,CY3,DA3,DC3,DE3,DG3,DI3,DK3").ClearContents
    [B25] = Range("DM2").Value
    [B26] = Range("DM2").Value
    [B27] = Range("DM2").Value
    [B28] = Range("DM2").Value
    [B29] = Range("DM2").Value
    [B30] = Range("DM2").Value
    [B31] = Range("DM2").Value
    [B32] = Range("DM2").Value
   
    End Sub

Some of you guys will have gathered my understanding of VBA is extremely limited, so I'd be very grateful for any assistance with this. 🤞
Many thanks
I often use a small function to check that a sheet exists

VBA Code:
Sub TestIt()

  If fncDoesWorksheetExist(ActiveWorkbook, "Sheet1") Then
    
    ' Code here if the sheet exists.
    
    MsgBox "Sheet Exists."
      
  Else
  
    ' Code here if the sheet does NOT exist.
    
    MsgBox "Sheet does not exist."
      
  End If
  
End Sub

Public Function fncDoesWorksheetExist(Wb As Workbook, strSheetName As String) As Boolean
Dim Ws As Worksheet

  For Each Ws In Wb.Sheets
          
    If Ws.Name = strSheetName Then
      fncDoesWorksheetExist = True
      Exit Function
    End If
    
  Next Ws

End Function
 
  • Like
Reactions: bdt
Upvote 0
VBA Code:
    Dim newWS As Worksheet
   
On Error Resume Next    'suppress error notification
Set newWS = Sheets("W.E." & Format(Range("C2").Value, "dd.mm.yy"))
On Error GoTo 0         're-enable error notification

If newWS Is Nothing Then    'it doesn't exist
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")
Else
    MsgBox " That worksheet already exists"
    Exit Sub
End If
NoSparks, I added your the above code to mine, works fine expect that it adds the seven days of the week to worksheet "OVERTIME", as shown in rows 308 to 321of the mini sheet. Is there any way to prevent this happening? Thanks in advance

LATHE MAGIC ABACUS building.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXY
30524/10/24Thur00004A40000
30625/10/24Fri00000A00000
30726/10/24Sat00000000000
30827/10/24Sun00000000000
30928/10/24Mon00000000000
31029/10/24Tues00000000000
31130/10/24Weds00000000000
31231/10/24Thur00000000000
31301/11/24Fri00000000000
31402/11/24Sat0000000000080004040800
31527/10/24Sun00000000000
31628/10/24Mon00000000000
31729/10/24Tues00000000000
31830/10/24Weds00000000000
31931/10/24Thur00000000000
32001/11/24Fri00000000000
32102/11/24Sat00000000000
322
323
324
325
OVERTIME
Cell Formulas
RangeFormula
N314:X314N314=SUM(C287:C314)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
C1:M154,C155:F155,H155:J155,C156:J159,K155:M159,C160:M1048576Cell Value=0textNO
C167:M399Cell Valuecontains "A"textNO
 
Upvote 0
Guys, ignore my last post. I was being stupid and put the code provided in the wrong place.
Many thanks again
 
Upvote 0
It appears that you use your ABACUS sheet for your weekly data entry,
is there a specific reason for that rather than using the actual weekly sheet ?
 
Upvote 0
@HighAndWilder you can check if a sheet exists in the active workbook without using a Function or a loop (A1 can be any valid cell reference)

VBA Code:
    If Evaluate("isref('Sheet1'!A1)") Then
        MsgBox "That name is taken"
        Exit Sub
    Else
        MsgBox "Sheet doesn't exist"
    End If

or using a variable for the sheet name

VBA Code:
    Dim mySht As String
  
    mySht = "Sheet1"
    If mySht = "" Then Exit Sub
   
    If Evaluate("isref('" & mySht & "'!A1)") Then
        MsgBox "That name is taken"
        Exit Sub
    Else
        MsgBox "Sheet doesn't exist"
    End If
 
Last edited:
  • Like
Reactions: bdt
Upvote 0
The Abacus sheet is used to assist with planning work for the following week. Once we're happy with the plan it is saved, for example this week would be W.E.26.10.24. If the plan changes for that week we can amend W.E.26.10.24 accordingly. The aim consistently assign the correct hours to each task for the week and to build a history of hours per task.
I don't know if there's a better way, but this format seems to work for us. Having said that I'm sure there will be modifications required to the design, for which I will no doubt be in need of assistance.
 
Upvote 0

Forum statistics

Threads
1,223,879
Messages
6,175,145
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top