VBAコードを変更してワークシートを1回だけ作成する方法

Question

VBAコードで作業しています。ドロップダウン選択ごとにシートを値としてコピーして、それぞれにワークシートを作成しますオプションを新しいブックのドロップダウンリストに追加します。問題は、すべてのコード内で正常に動作しているようですが、ドロップダウンオプションごとに完全に別のワークブックが作成されている点が異なります。私のドロップダウン選択は80の選択肢に似ており、成長することができます。だから私は80種類のワークブックは必要ありません。ドロップダウンの選択ごとに80のワークシートを持つ新しいワークブックが1つ必要です。そのブックのワークシートは、ドロップダウン選択ごとに1回だけ新しいブックを作成するように、コードを変更する方法はありますか。

ここに私のコードは

だ

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