递增变量值的计数器

Question

我正在尝试根据当前日期命名工作表。我需要一个计数器变量来命名工作表，以便它们是唯一的。

我做了两次尝试：

Sub COPIAR_MODELO()

Application.ScreenUpdating = False

    Dim i As Integer, x As Integer
    Dim shtname As String
    Dim WSDummy As Worksheet
    Dim TxtError As String
    Dim counter As Long
    counter = 0
    
Name01:
    For counter = 1 To 100 Step 0
        TxtError = ""
        counter = counter + 1
        shtname = Format(Now(), "dd mm yyyy") & " - " & counter
        On Error Resume Next
        Set WSDummy = Sheets(shtname)
        If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
    Next counter
    If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
    Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname

Application.ScreenUpdating = True

End Sub

预期结果：

和：

Sub COPIAR_MODELO()

Application.ScreenUpdating = False

    Dim i As Integer, x As Integer
    Dim shtname As String
    Dim WSDummy As Worksheet
    Dim TxtError As String
    Dim counter As Long
    
    TxtError = ""
    shtname = Format(Now(), "dd mm yyyy")
    On Error Resume Next
    Set WSDummy = Sheets(shtname)
    If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
    If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
    If TxtError = "" Then GoTo NameOK
    
Name01:
    For counter = 1 To 100 Step 1
        counter = counter + 1
        shtname = Format(Now(), "dd mm yyyy") & " - " & counter
    Next counter
NameOK:
    Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname

Application.ScreenUpdating = True

End Sub

预期结果：

我会将此代码分配给一个形状，以根据当前日期创建工作表。
我更喜欢结果 2。

Answer 1

复制模板

Sub CopyTemplate()
    
    Const PROC_TITLE As String = "Copy Template"
    Const TEMPLATE_WORKSHEET_NAME As String = "MODELO - NFS"
    Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
    Const DATE_FORMAT As String = "dd mm yyyy"
    Const DATE_NUMBER_DELIMITER As String = " - "
    Const FIRST_NUMBER As Long = 2
    Const FIRST_WORKSHEET_HAS_NUMBER As Boolean = False
    Const INPUT_BOX_PROMPT As String = "Input number of worksheets to create."
    Const INPUT_BOX_DEFAULT As String = "1"
    
    Dim WorksheetsCount As String: WorksheetsCount _
        = InputBox(INPUT_BOX_PROMPT, PROC_TITLE, INPUT_BOX_DEFAULT)
    If Len(WorksheetsCount) = 0 Then Exit Sub
    
    Dim DateName As String: DateName = Format(Date, DATE_FORMAT)
    
    Dim NewName As String: NewName = DateName
    Dim NewNumber As Long: NewNumber = FIRST_NUMBER
    
    If FIRST_WORKSHEET_HAS_NUMBER Then
        NewName = NewName & DATE_NUMBER_DELIMITER & NewNumber
        NewNumber = NewNumber + 1
    End If
        
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim wsTemplate As Worksheet
    Set wsTemplate = wb.Worksheets(TEMPLATE_WORKSHEET_NAME)
    Dim wsBefore As Worksheet
    Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
    
    Dim wsNew As Worksheet
    Dim WorksheetNumber As Long
    
    Application.ScreenUpdating = False
    
    Do While WorksheetNumber < WorksheetsCount
        On Error Resume Next
            Set wsNew = wb.Worksheets(NewName)
        On Error GoTo 0
        If wsNew Is Nothing Then
            wsTemplate.Copy Before:=wsBefore
            wsBefore.Previous.Name = NewName
            WorksheetNumber = WorksheetNumber + 1
        Else
            NewName = DateName & DATE_NUMBER_DELIMITER & NewNumber
            NewNumber = NewNumber + 1
            Set wsNew = Nothing
        End If
    Loop

    Application.ScreenUpdating = True
    
    MsgBox WorksheetsCount & " worksheet" & IIf(WorksheetsCount = 1, "", "s") _
        & " created.", vbInformation, PROC_TITLE

End Sub

如果玩得太过...

Sub DeleteCreatedWorksheets()
    
    Const PROC_TITLE As String = "Delete Created Worksheets"
    Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim wsBefore As Worksheet
    Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
    
    Dim wsIndex As Long: wsIndex = wsBefore.Index - 1
    
    If wsIndex > 0 Then
        Application.DisplayAlerts = False
            Dim n As Long
            For n = wsIndex To 1 Step -1
                wb.Worksheets(n).Delete
            Next n
        Application.DisplayAlerts = True
    End If
    
    MsgBox wsIndex & " created worksheet" _
        & IIf(wsIndex = 1, "", "s") & " deleted.", _
        vbInformation, PROC_TITLE

End Sub