宏循环下拉，并为每个下拉选择创建一个工作表

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保存到所需位置，然后关闭它。