基於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都必須存在值之後才能繼續。

目前沒有檢查非法工作表名稱字符。你可能想要熟悉這些並添加一些錯誤檢查。