I have been working on a Macro
that will automatically add new Annual Worksheets
when the Calendar Year
Changes. My current Code
is as follows:
Option Explicit
Sub addAnnualWkst()
Dim ws As Worksheet
Dim wsM As Worksheet
Dim strName As String
Dim strNamePreYr As String
Dim bCheck As Boolean
Dim pID As String
Dim rw
Set propIDs = ThisWorkbook.Names("propIDs").RefersToRange
Set actStatus = ThisWorkbook.Names("actStatus").RefersToRange
On Error Resume Next
Set wsM = Worksheets("WkstMaster")
For rw = 1 To propIDs.Count
If propIDs.Cells(rw, 1).Value2 <> vbNullString Then
If actStatus.Cells(rw, 1).Value2 = True Then
pID = propIDs.Cells(rw, 1).Value2
strName = pID & "_" & (Format(Date, "yyyy"))
strNamePreYr = pID & "_" & (Format(Date, "yyyy") - 1)
bCheck = Len(Sheets(strName).Name) > 0
Debug.Print pID, strName, strNamePreYr, bCheck
If bCheck = False Then
'add new sheet after Previous Year's Worksheet
wsM.Copy After:=Sheets(strNamePreYr)
ActiveSheet.Name = strName
End If
End If
End If
Next
Set wsM = Nothing
End Sub
the code above is based in part on on a Macro
I found in a Tutorial
I found and the Module Code
is:
Option Explicit
Sub AddMonthWkst()
Dim ws As Worksheet
Dim wsM As Worksheet
Dim strName As String
Dim bCheck As Boolean
On Error Resume Next
Set wsM = Sheets("Wkst_Master")
strName = Format(Date, "yyyy_mm")
bCheck = Len(Sheets(strName).Name) > 0
If bCheck = False Then
'add new sheet after Instructions
wsM.Copy After:=Sheets(1)
ActiveSheet.Name = strName
End If
Set wsM = Nothing
End Sub
The above 'code' works as advertised! bCheck
returns False
and the new worksheet is added. I am able to rename the worksheet tab from the current month 05
to the previous month 04
, save and close the workbook and when I reopen the workbook a new worksheet is automatically added with the 05
month extension.
I modified the code slightly to fit my needs and incapsulated that code in a subroutine
I successfully use in different parts of the application where I select pIDs
based on actStatus
.
I have active Worksheet Tabs
for the various PropIDs
as shown in this image:
When I run the Macro
the Immediate Window
shows ALL Active pIDs
with a pCheck Value
as True
when the pID "Rev"
should return a value of False
because pID "Rev"
does not have a WorkSheet
for the current year!
As one can see for the Immediate window
screenshot below, all the relevant pIDs
are there!
If I disable the 'On Error Resume Next' line I get the Runtime Error: 9, Script out of range
error and with or without the Error Trap
the worksheet is not added. the Error
happens at the highlighted
line of code
.
Please help me to resolve this issue. I know it is something simple I am missing! Thanks in advance.
CodePudding user response:
This is your problem:
Sub TesterLoop()
Dim bCheck As Boolean, s
On Error Resume Next
'Sheet4 doesn't exist
For Each s In Array("Sheet1", "Sheet2", "Sheet4")
'if the next line has an error then the value of bCheck is *unchanged*
bCheck = Len(ThisWorkbook.Sheets(s).Name) > 0
Debug.Print s, bCheck
Next s
End Sub
Output:
Sheet1 True
Sheet2 True
Sheet4 True '<<<oops! Still has the Sheet2 value...
The value of bCheck
can only be set when that line executes with no error: if there's an error then bCheck
still has its initial False
value, or the value from the previous loop iteration.
If you add
bCheck = False
before that line it will fix your problem.
But it's a bad idea to let On Error Resume Next
cover that much of your code, and you'd be better off factoring out that check into a standalone function as suggested in the comments.
CodePudding user response:
Thanks to those who pointed me in direction of a possible solution.
Here is the the Solution I came up with!
Sub addAnnualWkst()
Dim ws As Worksheet
Dim wsM As Worksheet
Dim strName As String
Dim strNamePreYr As String
Dim bCheck As Boolean
Dim exists
Dim pID As String
Dim rw
Set propIDs = ThisWorkbook.Names("propIDs").RefersToRange
Set actStatus = ThisWorkbook.Names("actStatus").RefersToRange
Set wsM = Worksheets("WkstMaster")
For rw = 1 To propIDs.Count
If propIDs.Cells(rw, 1).Value2 <> vbNullString Then
If actStatus.Cells(rw, 1).Value2 = True Then
pID = propIDs.Cells(rw, 1).Value2
cName = pID & (Format(Date, "yyyy"))
strName = pID & "_" & (Format(Date, "yyyy"))
strNamePreYr = pID & "_" & (Format(Date, "yyyy") - 1)
If Not wsExists(strName) Then
Debug.Print pID, strName, strNamePreYr
wsM.Copy After:=Sheets(strNamePreYr)
ActiveSheet.Name = strName
End If
End If
End If
Next
Set wsM = Nothing
End Sub
Function wsExists(strName As String) As Boolean
Dim ws: For Each ws In Sheets
wsExists = (strName = ws.Name): If wsExists Then Exit Function
Next ws
End Function
The only 'pID' that appears in the Immediate Window
is the pID
missing the 2022
extension.