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

3 回答

• 0

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

  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
  

  回复于 2024-04-29T19:18:28+08:00
• 1

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

  然后，对于范围中的每个单元格，您可以使用 Match 函数查看它是否已存在于工作簿中 . 如果 Match 失败，则表示在工作表名称>>中找不到 MyCell.Value ，因此请创建它 .

  Code

  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
  

  回复于 2024-04-29T19:18:28+08:00
• 2

  我只是稍微调整了一下代码，以确保所有引用都完全合格 . 它应该更容易理解，并且您不会冒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
  

  回复于 2024-04-29T19:18:28+08:00