如何改变我的VBA代码，所以它只能创build一个工作簿，而不是每个其他选项的工作表

我正在处理一个VBA代码，对于每个下拉列表select，它复制工作表，因为值会在新工作簿的下拉列表中为每个选项创build一个工作表。 问题是一切似乎在我的代码工作正常，除了每个下拉选项它创build一个完全独立的工作簿。 我的下拉select就像80个选项，可以增长。 所以我不需要80个不同的工作簿。 我需要一个新的工作簿，每个下拉select80个工作表。 我怎样才能改变我的代码，以便它创build一个新的工作簿比每个下拉select是该工作簿中的工作表？

这是我的代码

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

尝试这个。 当我testing它时，我发现它完成了你所要求的

 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