如何创建具有相似名称的新工作表，如"Period1“、"Period”等

Question

如果我使用这种代码：

Sub CreateSheet()

    Dim ws As Worksheet
    With ThisWorkbook
        Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        ws.Name = "Period"
    End With End Sub

它创建一个名为"Period“的工作表。我想创建宏，当我第一次运行它时，它会创建名为"Period 1“的工作表。在第二次，它将创建“周期2"，等等，所以只有一个工作表/运行。

我该怎么做？提前感谢您的帮助。

Answer 1

尝尝这个

Sub Create()
Const LIMIT = 9
Dim ws As Worksheet
Dim i As Long

    With ThisWorkbook
        For i = 1 To LIMIT
            Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            ws.Name = "Period " & CStr(i)
        Next i
    End With

End Sub

Answer 2

基于附加信息，第一次拍摄可能是

Option Explicit

Sub Create()
Dim ws As Worksheet
Dim i As Long

    i = GetNr(ThisWorkbook, "Period*")


    With ThisWorkbook
            Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            ws.Name = "Period " & CStr(i + 1)
    End With

End Sub

Function GetNr(wb As Workbook, shtPattern As String) As Long
Dim maxNr As Long
Dim tempNr As Long

Dim ws As Worksheet
    For Each ws In wb.Worksheets
        If ws.Name Like shtPattern Then
            tempNr = onlyDigits(ws.Name)
            If tempNr > maxNr Then
                maxNr = tempNr
            End If
        End If
    Next ws
    GetNr = maxNr
End Function
Function onlyDigits(s As String) As String
    ' Variables needed (remember to use "option explicit").   '
    Dim retval As String    ' This is the return string.      '
    Dim i As Integer        ' Counter for character position. '

    ' Initialise return string to empty                       '
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = Len(s) To 1 Step -1
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
            retval = Mid(s, i, 1) + retval
        Else
            Exit For
        End If
    Next

    ' Then return the return string.                          '
    onlyDigits = retval
End Function

Answer 3

这将完全按照您的要求执行。将创建工作表周期，如果它已经存在，它将循环，直到找到下一个可用编号并创建下一个工作表。作为示例，我已经添加了它将从运行宏时处于活动状态的工作表复制范围A2:H20，并将其粘贴到新创建的工作表上。

Sub CopyToNewSheet()
    Dim ws As Worksheet
    Dim i As Long
    Dim SheetName As String, active as String
    active = ActiveSheet.Name
    SheetName = "Period"
    Do While SheetExists(SheetName) = True
        i = i + 1
        SheetName = "Period " & i
    Loop
    With ThisWorkbook
        Set ws = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
        ws.Name = SheetName
        .Sheets(active).Range("A2:H20").Copy
        .Sheets(SheetName).Range("A2").PasteSpecial
        'I could've used ws.Range("A2").PasteSpecial instead but I wanted the copy and paste to look similar.
    End With
End Sub
Function SheetExists(SheetName As String, Optional wb As Excel.Workbook)
   Dim s As Excel.Worksheet
   If wb Is Nothing Then Set wb = ThisWorkbook
   On Error Resume Next
   Set s = wb.Sheets(SheetName)
   On Error GoTo 0
   SheetExists = Not s Is Nothing
End Function

取自此处的SheetExists函数：Excel VBA If WorkSheet("wsName") Exists