如何改變我的VBA代碼，所以它只創建一個工作簿，而不是每個其他選項的工作表

Question

我正在處理一個VBA代碼，對於每個下拉選擇它複製工作表，因爲值會爲每個工作表創建一個工作表選項在新工作簿的下拉列表中。問題是我的代碼中的一切看起來都很好，除了每個下拉選項都創建一個完全獨立的工作簿。我的下拉選擇就像80個選項，可以增長。所以我不需要80個不同的工作簿。我需要爲每個下拉選項選擇一個包含80個工作表的新工作簿。如何更改我的代碼，以便創建一個新的工作簿，而不是每個下拉選擇都是該工作簿中的工作表？

這裏是我的代碼

Sub Worksheet_Create() 

Dim cell As Range 
Dim counter As Long 
Dim Dashboard As Worksheet 

Set Dashboard = Sheets("Business Plans") 

For Each cell In Worksheets("dd").Range("$C3:$C75") 
    If cell.Value = "" Then 
     counter = counter + 1 
     Application.StatusBar = "Processing file: " & counter & "/1042" 
    Else 
     counter = counter + 1 
     Application.StatusBar = "Processing file: " & counter & "/1042" 

     Application.DisplayAlerts = False 

     With Dashboard 
     .Range("$A$2").Value = cell.Value 
      With ThisWorkbook 
       .Worksheets("Business Plans").Copy 
       ActiveSheet.Cells.Copy 
       ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues 
       ActiveSheet.Name = cell.Value 
      End With 
      Application.CutCopyMode = False 

     End With 
    End If 
Next cell 

Application.DisplayAlerts = True 

End Sub 

Answer 1

嘗試。當我測試它時，我發現它完成了你所要求的

Sub Worksheet_Create() 

Dim cell As Range 
Dim counter As Long 
Dim Dashboard As Worksheet 
Dim newWB As Workbook 
Dim wb1 As Workbook 

Set wb1 = ThisWorkbook 
Set newWB = Workbooks.Add 
Set Dashboard = wb1.Sheets("Business Plans") 

Application.DisplayAlerts = False 

For Each cell In wb1.Worksheets("dd").Range("$C3:$C75") 
    If cell.Value = "" Then 
     counter = counter + 1 
     Application.StatusBar = "Processing file: " & counter & "/1042" 
    Else 
     counter = counter + 1 
     Application.StatusBar = "Processing file: " & counter & "/1042" 

     With Dashboard 
     .Range("$A$2").Value = cell.Value 
      With wb1 
       .Worksheets("Business Plans").Copy After:=newWB.Worksheets(1) 
       ActiveSheet.Cells.Copy 
       ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues 
       ActiveSheet.Name = cell.Value 
      End With 
      Application.CutCopyMode = False 
     End With 
    End If 
Next cell 

Application.DisplayAlerts = True 

End Sub