基于Excel中的列表自动创建工作表

Question

我试图实现以下目标。

当我在范围A5：A50中的“主”工作表上输入一个值时，会运行一个宏，它将创建一个与该值相同名称的新工作表，然后将该模板复制到新工作表中。

除此之外，我还想将Master工作表上输入的值旁边的值复制到此新工作表中，以便自动进行计算。

例如，我在A5中输入'1'，在B5中输入'2'。我想创建一个名称为'1'的新工作表，从'模板'工作表复制模板，并将B5的值复制到名为'1'的新工作表中。

我有以下代码，但它也试图复制模板工作表与宏运行，这会导致错误，因为名称为'Template'的工作表已经存在。

Sub CreateAndNameWorksheets() 
    Dim c As Range 

    Application.ScreenUpdating = False 
    For Each c In Sheets("Master").Range("A5:A50") 
     Sheets("Template").Copy After:=Sheets(Sheets.Count) 
     With c 
      ActiveSheet.Name = .Value 
      .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _ 
       "'" & .Text & "'!A1", TextToDisplay:=.Text 
     End With 
    Next c 
    Application.ScreenUpdating = True 
End Sub 

Answer 1

右键单击主表的名称选项卡，选择查看代码。当VBE打开时，将以下内容粘贴到标题为Book1 - Master（代码）的窗口中。

Private Sub Worksheet_Change(ByVal target As Range) 
    If Not Intersect(target, Rows("5:50"), Columns("A:B")) Is Nothing Then 
     On Error GoTo bm_Safe_Exit 
     Application.ScreenUpdating = False 
     Application.EnableEvents = False 
     Application.DisplayAlerts = False 
     Application.Calculation = xlCalculationManual 
     Dim r As Long, rw As Long, w As Long 
     For r = 1 To Intersect(target, Rows("5:50"), Columns("A:B")).Rows.Count 
      rw = Intersect(target, Rows("5:50"), Columns("A:B")).Rows(r).Row 
      If Application.CountA(Cells(rw, 1).Resize(1, 2)) = 2 Then 
       For w = 1 To Worksheets.Count 
        If LCase(Worksheets(w).Name) = LCase(Cells(rw, 1).Value2) Then Exit For 
       Next w 
       If w > Worksheets.Count Then 
        Worksheets("Template").Visible = True 
        Worksheets("Template").Copy after:=Sheets(Sheets.Count) 
        With Sheets(Sheets.Count) 
         .Name = Cells(rw, 1).Value2 
         .Cells(1, 1) = Cells(rw, 2).Value 
        End With 
       End If 
       With Cells(rw, 1) 
        .Parent.Hyperlinks.Add Anchor:=Cells(rw, 1), Address:="", _ 
         SubAddress:="'" & .Value2 & "'!A1", TextToDisplay:=.Value2 
       End With 
      End If 
     Next r 
     Me.Activate 
    End If 
bm_Safe_Exit: 
    Worksheets("Template").Visible = xlVeryHidden 
    Me.Activate 
    Application.Calculation = xlCalculationAutomatic 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
End Sub 

注意，这取决于你有，以生成新的工作表命名为模板工作。它还保留了模板工作表xlVeryHidden，这意味着如果您尝试取消隐藏，它将不会显示。进入VBE并使用属性窗口（例如F4）将可见性设置为可见。

该例程应该能够在多个值中粘贴到A2：B50中，但它会放弃列A中已经存在的建议工作表名称。在任何行的列A和列B都必须存在值之后才能继续。

目前没有检查非法工作表名称字符。你可能想要熟悉这些并添加一些错误检查。