VBA创build一个新的基于范围的工作表只有现有的不能被发现

我试图创build一个macros来创build新的工作表，如果现有的工作表不存在，这个工作表的名字是以列A（从“主”的A5）开始的。每天更新“主” – 所以我试图build立一些代码，通过循环所有现有的表检查列表中的新名称如果列A（表“主”）中的单元格已经有工作表相同的名称，代码将不会执行任何操作，并转到设置范围中的下一个单元格，但是如果macros在列表中find不在工作簿的工作表名称中的名称，则会添加一个工作表（“模板“），并以列表范围的单元格值命名。到目前为止，我可以创build新的工作表，但同时，对于其他现有的工作表，该macros还创build了附加工作表（”模板（2）“） ，“模板（3）”，“模板（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

你需要检查表单是否存在，这是我写的一个有效的函数：

 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 2

你可以用不同的方式尝试。 首先，遍历Worksheets簿中的所有Worksheets ，并将其名称保存在sheetNames数组中。

然后，对于您的范围中的每个单元格，可以使用“ Matchfunction查看它是否已存在于工作簿中。 如果Match失败，这意味着这个MyCell.Value没有在工作表名称中find>>所以创build它。

码

 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 3

我只是稍微调整了你的代码，以确保所有引用都完全合格。 应该更容易遵循，而且不要担心Excel会因为复制到哪里而感到困惑。

testing和为我工作

 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