Save Multiple Active Workbooks

[temerson]

Hello,

I have the following code:

Sub VisibleSheets(Optional ByVal Control As IRibbonControl)
On Error Resume Next


Dim ws As Worksheet
Dim wbNew As Workbook
Dim WSHShell As Object
Dim DesktopPath As String
Dim VendorName As String
Dim StoreName As String


VendorName = Range("I2")
StoreName = Range("J2")


Set WSHShell = CreateObject("WScript.Shell")
DesktopPath = WSHShell.SpecialFolders("Desktop")

For Each ws In ActiveWorkbook.Sheets
If ws.Visible Then
Debug.Print "Exporting: " & ws.Name
ws.Copy
Set wbNew = Application.ActiveWorkbook

Set wbNew = Nothing


DesktopPath = WSHShell.SpecialFolders("Desktop")
ActiveWorkbook.SaveAs DesktopPath & "\#" & StoreName & " OPENING DAIRY ORDER-" & VendorName & ".xls"


End If
Next ws

Set ws = Nothing
Set WSHShell = Nothing


End Sub

The end goal is to have each tab in the workbook have its own workbook, then save it onto my desktop. The problem I am facing is after the first workbook is saved, the proceeding active workbooks fail to save.

 

[DanteAmor]

Change your code to the following macro.

Sub Save_Multiple_Workbooks()
  Dim ws As Worksheet, wbNew As Workbook, DPath As String, VendorN As String, StoreN As String
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  DPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
  For Each ws In ThisWorkbook.Sheets
    If ws.Visible Then
      VendorN = ws.Range("I2")
      StoreN = ws.Range("J2")
      ws.Copy
      Set wbNew = ActiveWorkbook
      wbNew.SaveAs DPath & "\#" & StoreN & " OPENING DAIRY ORDER-" & VendorN & ".xls"
      wbNew.Close False
    End If
  Next ws
  Set ws = Nothing
End Sub

 

[temerson]

Perfect! Thank you! Never knew you could Dim multiple things at once, that is a plus!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.