循环通过下拉列表并将工作簿保存为新文件。

Question

嗨，我有下面的代码，它循环遍历下拉选择，并根据单元格G3中的命名范围将每个结果保存为新的工作簿。如果有人能帮忙的话，我试着编辑代码，这样它就可以将所有工作表保存到新文件中，而不仅仅是活动文件。谢谢

Sub myFiles()   
    
Dim wb As Workbook           
Dim ws As Worksheet   
Dim nwb As Workbook      
Dim nws As Worksheet      
Dim rng As Range    
Dim Path As String    
Dim myDate As String       

Set wb = ThisWorkbook     
Set ws = wb.Worksheets("Summary")    
Set rng = ws.Range("G3")    

Path = "C:\Users\bradley\Desktop\Sales by Month\"   
 
myDate = Format(Now(), "MM-DD-YYYY")    
  
For i = 1 To 4    
    rng = ws.Range("J" & i)           
    ws.Copy        
    
    Set nwb = ActiveWorkbook   
    Set nws = nwb.Worksheets("Summary")      

     With nws  
  
         Cells.Copy    
         Cells.PasteSpecial (xlPasteValues)  
  
     End With    

     Application.DisplayAlerts = False    
     nwb.SaveAs FileName:=Path & rng & " " & myDate & ".xlsx", 
     FileFormat:=xlWorkbookDefault
     nwb.Close    
     Application.DisplayAlerts = True    

Next i    

End Sub         

Answer 1

循环遍历工作表，但只在第一个工作表上创建工作簿。

Option Explicit

Sub myFiles()
       
    Const FOLDER = "C:\Users\bradley\Desktop\Sales by Month\"
    
    Dim wb As Workbook, nwb As Workbook
    Dim ws As Worksheet, rng As Range
    Dim myDate As String, i As Long, j As Long
    Dim filename As String
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Summary")
    
    Set rng = ws.Range("G3")
    myDate = Format(Now(), "MM-DD-YYYY")
      
    Application.ScreenUpdating = False
    For i = 1 To 4
        rng.Value2 = ws.Range("J" & i).Value2
        
        ' copy all sheets
        For j = 1 To wb.Sheets.Count
            If j = 1 Then
                wb.Sheets(j).Copy
                Set nwb = ActiveWorkbook
            Else
                wb.Sheets(j).Copy after:=nwb.Sheets(j - 1)
            End If

            With nwb.Sheets(j)
                .UsedRange.Value2 = .UsedRange.Value2
            End With
        Next
        
        ' save workbook
        filename = FOLDER & rng.Value2 & " " & myDate & ".xlsx"
        Application.DisplayAlerts = False
        nwb.SaveAs filename:=filename, FileFormat:=xlWorkbookDefault
        nwb.Close
        Application.DisplayAlerts = True
    Next i
    Application.ScreenUpdating = True

    MsgBox "Done"

End Sub