如何创建具有相似名称的新工作表，例如“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”的工作表。第二次它会创建“Period 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