excel - 如果找不到现有工作表，则根据范围创建新工作表

Question

如果不存在，我正在尝试通过复制"template"来创建一个新工作表。

工作表的名称基于 A 列(从“主”的 A5 开始的列表)。 “大师”中的列表将每天更新。

我通过循环浏览现有表格来检查列表中的新名称。如果 A 列中的一个单元格(工作表“主”)已经有一个名称为工作表，则什么也不做，转到下一个单元格。如果列表中的名称不在工作簿的工作表名称中，则会添加一个工作表("template"的副本)并以单元格值命名。

我能够创建新的工作表，但是对于每个现有的工作表，宏都会创建额外的工作表('template(2)'、'template(3)'、'template(4)'，等等)。

我应该怎么做才能消除那些新的“模板(＃)”？

这是我的代码:

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Master").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange

    On Error Resume Next

    Sheets("Template").Copy After:=Sheets(Sheets.Count)

    With Sheets(Sheets.Count)
        .Name = MyCell.Value
        .Cells(2, 1) = MyCell.Value

    End With

    On Error GoTo 0

    MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"

Next MyCell

End Sub

Answer 1

你可以换一种方式试试。首先，遍历所有Worksheets在工作簿中并将他们的名字保存在 sheetNames大批。

然后，对于范围内的每个单元格，您可以使用 Match函数来查看它是否已经存在于您的工作簿中。如果 Match失败，这意味着 MyCell.Value在工作表名称中找不到 >> 所以创建它。

代码

Option Explicit

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range
Dim sheetNames() As String
Dim ws As Worksheet
Dim i As Integer

Set MyRange = Sheets("Master").Range("A5", Sheets("Master").Range("A5").End(xlDown))

' put all sheet name from Range A5 in "Master" sheet into an array

ReDim sheetNames(1 To 100) ' = Application.Transpose(MyRange.Value)

i = 1
' loop through all worksheets and get their names
For Each ws In Worksheets
    sheetNames(i) = ws.Name

    i = i + 1
Next ws

'resice array to actual number of sheets in workbook
ReDim Preserve sheetNames(1 To i - 1)

For Each MyCell In MyRange.Cells

    ' sheet name not found in workbook sheets array >> create it
    If IsError(Application.Match(MyCell.Value, sheetNames, 0)) Then
        Sheets("Template").Copy After:=Sheets(Sheets.Count)

        With Sheets(Sheets.Count)
            .Name = MyCell.Value
            .Cells(2, 1) = MyCell.Value
        End With

        MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"

    Else '<-- sheet name exists in array (don't create a new one)
        ' do nothing
    End If
Next MyCell

' ====== Delete the worksheets with (#) section =====
Application.DisplayAlerts = False
For Each ws In Worksheets       
    If ws.Name Like "*(?)*" Then ws.Delete
Next ws
Application.DisplayAlerts = True

End Sub