Exporting All Sheets to New Workbook

[bearcub]

I was trying to export all sheets from one file today to separate workbooks. Reason is that I had to create a new file for each sheet in this file so I could import each workbook separately into a commissions application. Each sheet was a renewal schedule for a difficult regional vice president. I had to create about 10 files because I had 10 separate sheets in the main file. I didn't want to move each sheet, just copy each sheet into an individual workbook.

I looked around on the web for some vb code but couldn't find the exact code that I needed. I stumbled on this code I'm posting now which I would like to tweak. I would like to make it more dynamic and robust.

I remember there are forum rules regarding posting code but it has been a couple of years since I've posted a question on this forum. I apologize in the advance for not remembering the protocol.

Right now, the code is telling me where I can save the files but I would like to modify the code so that I can point to a location of my choice. Plus, I would like to make the replace the "Master Sheet" name with a generic name because I might have different sheet names I don't want to export.

Would this be difficult to do? Or, is their a more efficient code that is more dynamic?

Thank you for your help,

Michael

[/B]

[TABLE]
[TR]
[TD]Sub Export All Sheet to Individual Workbooks ()[/TD]
[/TR]
[TR]
[TD]Dim a as Integer[/TD]
[/TR]
[TR]
[TD]Dim ws as Worksheet[/TD]
[/TR]
[TR]
[TD]Dim wb as workbook[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]a = ThisWorkbook.Worksheets.Count[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]For I = 1 to a[/TD]
[/TR]
[TR]
[TD]If ThisWorkbook.Worksheets(i) . Name <>"Master Sheet" Then  <-- Change Master sheet to sheet name  of my choice[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Set wb = Workbooks.Add[/TD]
[/TR]
[TR]
[TD]This Workbook. Worksheets(i). Copy before: wb.Worksheets (1)[/TD]
[/TR]
[TR]
[TD]wb.SaveAs "C:\Users\ExcelDestination\Desktop\All Files" & "\" & ActiveSheet.Name & ".xlsx"  <--I would like to replace this with the ability to point to where I want to save the file[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]wb.Close savechanges = True[/TD]
[/TR]
[TR]
[TD]End if[/TD]
[/TR]
[TR]
[TD]Next i[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]ThisWorkbook. Activate[/TD]
[/TR]
[TR]
[TD]ThisWorkbook.Worksheets("Master Sheet").Activate[/TD]
[/TR]
[TR]
[TD]ThisWorkbook.Worksheets("Master Sheet").Cells (1,1).Select[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]MsgBox ("Task Completed")[/TD]
[/TR]
[TR]
[TD]End Sub[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[/TABLE]
[B][End Code][/B]

 

[bearcub]

Forgot to upload the code image

 

[bearcub]

Sorry, I looked at my post and saw that the actual code was difficult to read. Here it is in text format. I apologize for the messy post

Sub Export All Sheet to Individual Workbooks ()

Dim a as Integer

Dim ws as Worksheet

Dim wb as workbook

a = ThisWorkbook.Worksheets.Count

For I = 1 to a

If ThisWorkbook.Worksheets(i) . Name <>"Master Sheet" Then

Set wb = Workbooks.Add

This Workbook. Worksheets(i). Copy before: wb.Worksheets (1)

wb.SaveAs "C:\Users\ExcelDestination\Desktop\All Files" & "\" & ActiveSheet.Name & ".xlsx"

wb.Close savechanges = True

End if

Next i

ThisWorkbook. Activate

ThisWorkbook.Worksheets("Master Sheet").Activate

ThisWorkbook.Worksheets("Master Sheet").Cells (1,1).Select

MsgBox ("Task Completed")

End Sub

 

[jolivanes]

Sub Save_All_Sheets_As_Workbooks()
Dim wb1 As Workbook, folder, i As Long
Set wb1 = ThisWorkbook
On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        folder = .SelectedItems(1)
    End With
    If folder = False Then MsgBox "No folder selected.": Exit Sub
Application.ScreenUpdating = False
    For i = 1 To wb1.Sheets.Count
        If wb1.Sheets(i).name <> "Master" Then
            wb1.Sheets(i).Copy
                Application.DisplayAlerts = False
                    With ActiveWorkbook
                        .SaveAs folder & "\" & wb1.Sheets(i).name & ".xlsx", FileFormat:=51
                    .Close
                End With
            Application.DisplayAlerts = True
        End If
    Next i
Application.ScreenUpdating = True
End Sub

 

[jolivanes]

Some sheets excepted

Sub Save_All_Sheets_Except_Some()
Dim wb1 As Workbook, folder, ws As Worksheet
Set wb1 = ThisWorkbook
On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        folder = .SelectedItems(1)
    End With
    If folder = False Then MsgBox "No folder selected.": Exit Sub
Application.ScreenUpdating = False
    For Each ws In wb1.Worksheets
        Select Case ws.name
            Case "Master", "Sheet3", "Sheet6", "Sheet8"    '<----- Ignore these sheets. Add/Change as needed
            Case Else
                ws.Copy
                    With ActiveWorkbook
                        .SaveAs folder & "\" & ws.name & ".xlsx", FileFormat:=51
                    .Close
                End With
        End Select
    Next ws
Application.ScreenUpdating = True
End Sub

 

[bearcub]

Thank you for the code. I looked at the code and it looks more elegant and dynamic than the code that I presently.

However, the macro is running properly so I figure I am not doing something properly in running it. Can you let me know what I am doing wrong?

I copied the revised macro into my Personal.xlsx workbook and make the source file that I want to copy from the activewindow before going to the VBA Editor to run the code. Do I need to run it from a commandbutton?

These are the sheets that i wanted to copy into the VBA Files folder on my harddrive.

This is the result.

I did save it to our google drive and not to my hard drive. Could this be the issue?

 

[jolivanes]

Re: "Personal.xlsx"
Where did you find this? Is that the proper spelling (extension)?

If you changed anything at all, what did you change?
Show us your whole code that does not work. Change actual people names to fictional names if present in the code.

BTW, when putting code in here, one way is to copy it into notepad and copy from notepad into here. Don't forget to highlight your inserted code and use the "</>" to get codetags around the code.

 

[jolivanes]

 

[jolivanes]

Change

Set wb1 = ThisWorkbook

to

Set wb1 = ActiveWorkbook

In this line put the names of the sheets you DO NOT want to export.

Case "Master", "Sheet3", "Sheet6", "Sheet8"

Each sheet name as shown here, between double quotation marks and separated by a comma.
Try it on a folder on your C Drive first. I do not use Google Drive but I can't see why it would not work if you selected it.

 

[bearcub]

Thank you, it works like a charm! Just for fun, I did try to run this macro in a folder on our Google drive and it kept on looping. But, it ran correctly when the file was on my hard drive. Interesting that went into an infinite loop when I ran it in the "cloud"