宏循環下拉，併爲每個下拉選擇創建一個工作表

Question

所以我有一個名爲「商業計劃」，我有一個下拉列表單元格A2中的下拉菜單，這是一個名爲「設施」的範圍下拉選擇和所有儀表板數據被查找驅動。我想要做的是首先創建一個新的工作簿，而不是每個下拉選擇的新選項卡，選項卡的格式相同，但數據粘貼爲值。我試圖創建下面的代碼來將每個下拉選擇保存爲PDF，但我一直不成功。任何關於如何讓代碼工作的見解都會很棒。

Sub Worksheet_Generator() 

    Dim cell As Range 
    Dim wsSummary As Worksheet 
    Dim counter As Long 

    Set wsSummary = 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" 

      With wsSummary 
       .Range("$A$2").Value = cell.Value 
       ActiveSheet.Copy After:=Worksheets(Worksheets.Count) 
       ActiveSheet.Copy 
       With ActiveSheet.UsedRange 
        .Value = .Value 
       End With 
      End With 
     End If 
    Next cell 

Set wsSummary = Nothing 
End Sub 

Answer 1

我認爲你正在尋找類似於下面的東西（改編自copying-dynamic-rows-into-new-workbook-and-save-it）。

Option Explicit 
Sub grabber() 
    Dim thisWb As Workbook: Set thisWb = ThisWorkbook 
    Dim thisWs As Worksheet: Set thisWs = thisWb.Worksheets("dd") 'replace with relevant name 
    Dim newBook As Workbook 
    Dim newws As Worksheet 
    Dim pathToNewWb As String 
    Dim uKeys 
    Dim currentPath, columnWithKey, numCols, numRows, uKey, dataStartRow, columnKeyName 

    'nobody likes flickering screens 
    Application.ScreenUpdating = False 
    'remove any filter applied to the data 
    thisWs.AutoFilterMode = False 

    'get the path of the workbook folder 
    currentPath = Application.ThisWorkbook.Path 

    'Set the stage 
    '###Hardcode### 
    columnKeyName = "Facility" 'name of the column with the facility values 
    dataStartRow = 4 'this is a pure guess, correct as relevenat. Use the header row index 
    pathToNewWb = currentPath & "/Business Plans.xlsx" ' where to put the new excel, if you want a saveas prompt you should google "Application.FileDialog(msoFileDialogSaveAs)" 
    uKeys = Range("Facilities").Value 
    '###Hardcode End### 
    columnWithKey = thisWs.Range(dataStartRow & ":" & dataStartRow).Find(what:=columnKeyName, LookIn:=xlValues).Column 
    numCols = thisWs.UsedRange.Columns.Count 

    'extract the index of the last used row in the worksheet 
    numRows = thisWs.UsedRange.Rows.Count 

    'create the new workbook 
    Set newBook = Workbooks.Add 

    'loop the facilities, and do the work 
    For Each uKey In uKeys 

     'Filter the keys column for a unique key 
     thisWs.Range(thisWs.Cells(dataStartRow, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey 

     'copy the sheet 
     thisWs.UsedRange.Copy 

     'Create a new ws for the facility, and paste as values 
     Set newws = newBook.Worksheets.Add 
     With newws 
      .Name = uKey 'I assume the name of the facility is the relevant sheet name 
      .Range("A1").PasteSpecial xlPasteValues 
     End With 

     'remove autofilter (paranoid parrot) 
     thisWs.AutoFilterMode = False 

    Next uKey 

    'save the new workbook 
    newBook.SaveAs pathToNewWb 
    newBook.Close 

End Sub 

編輯：

由於我還沒有看到你的數據，如果它需要一些修改，我不會感到驚訝。

首先，我嘗試對包含數據（### Hardcode ###位）的工作表「dd」的範圍進行「構建」，定義輸出的路徑，並確定可以過濾的列對應於命名範圍「設施」的值。

我檢索命名範圍「Facilities」（進入uKeys）的值，​​並創建輸出工作簿（newBook）。然後我們遍歷for循環中uKeys的每個值（uKey）。在循環中，我爲uKey應用了一個自動過濾器。過濾後，在newBook中創建工作表（newWs），並將過濾的工作表「dd」複製粘貼到newWs中。然後關閉自動過濾器，工作表「dd」返回到未過濾狀態。

最後，我們將newBook保存到所需位置，然後關閉它。