Question

我正在尝试通过复制“模板”来创建新的工作表，如果不存在的话。

表单的名称基于A列（从'Master'的A5开始的列表）。 “主人”中的列表将每天更新。

我通过循环显示现有的表单来检查列表中的新名称。如果列A（Sheet'Master'）中的单元格已经有一个带有名称的工作表，则不执行任何操作并转到下一个单元格。如果列表中的名称不在工作簿的工作表名称中，则会添加工作表（“模板”的副本）并以单元格值命名。

我能够创建新的工作表，但是对于每个现有的工作表，宏都会创建其他工作表（'template（2）'，'template（3）'，'template（4）'等）。< / p>

我应该怎样做才能消除那些新的'模板（＃）'？

这是我的代码：

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失败，则表示在工作表名称＆gt;＆gt;中找不到此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

Answer 2

您需要先检查工作表是否存在，这是我写的一个有效的功能：

Function CheckSheetExists(ByVal name As String)

' checks if a worksheet already exists

Dim retVal As Boolean

retVal = False

For s = 1 To Sheets.Count
    If Sheets(s).name = name Then
        retVal = True
        Exit For
    End If
Next s

CheckSheetExists = retVal

End Function

所以，修改你的代码：

If CheckSheetExists(MyCell.Value) = false then

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

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

    End With
End If

Answer 3

我只是稍微调整了你的代码，以确保所有引用都是完全合格的。它应该更容易理解，并且您不会冒Excel让您对从哪里复制到哪里感到困惑的风险。

经过测试并适合我

Sub AutoAddSheet()

Dim MyCell As Range, MyRange As Range

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

Dim wksTemplate As Worksheet
Set wksTemplate = ThisWorkbook.Worksheets("Template")

For Each MyCell In MyRange
    wksTemplate.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

    Dim wsNew As Worksheet
    Set wsNew = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

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

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

End Sub

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

3 个答案: