遍历下拉列表并将工作簿另存为新文件

Posted 2023-02-19

【中文标题】遍历下拉列表并将工作簿另存为新文件

【英文标题】：Loop through drop down list and save the workbook as a new file

【发布时间】：2022-01-22 06:36:17

【问题描述】：

您好，我有以下代码循环下拉选择并将每个结果保存为基于单元格 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         

【问题讨论】：

注意：不是With nws Cells.Copy ，而是With nws .Cells.Copy

您好上面的代码没有任何错误，只需要添加它以便复制所有工作表

wb.Sheets.Copy 将从wb复制所有工作表

嗨，代码似乎与建议的更改一起使用，我如何将工作簿保存为启用宏的书，因为其中一张表包含宏，再次感谢

【参考方案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