Macro to copy all worksheets into CSV files

[cidfidou]

Hi Excel Masters,

I am writing a new thread to make sure this is clear.

As i am useless in VBA, I am hoping that someone will write or copy an existing code to do the following :

- Save all worksheets of the current workbook into CSV files under the name of each worksheets
- the cherry on top of the cake would be a pop up window letting the user choose the location where to save the csv files (only once for all the worksheets)

As per usual, thanks in advance

 

[cytop]

Sub CreateWorkbooks()

    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Object
    Dim strSavePath As String

    Dim oFldr As FileDialog
   
    On Error GoTo ErrorHandler

    Set oFldr = Application.FileDialog(msoFileDialogFolderPicker)
    
    With oFldr
        .Title = "Select a directory"
        .AllowMultiSelect = False
        .InitialFileName = ActiveWorkbook.Path
        If .Show = True Then
            strSavePath = .SelectedItems(1)
        Else
            MsgBox "no folder selected...", vbExclamation
            Exit Sub
        End If
        
    End With

    Application.ScreenUpdating = False

    Set wbSource = ActiveWorkbook


    For Each sht In wbSource.Sheets
        sht.Copy
        Set wbDest = ActiveWorkbook
        wbDest.SaveAs strSavePath & sht.Name, xlCSV
        wbDest.Close
    Next

    Application.ScreenUpdating = True

    Exit Sub


ErrorHandler:
    MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
End Sub

 

[Pascal]

Hi,

Thought you'd want to know.....

Sub CreateWorkbooks()

    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim objSheet As Object
    Dim strSavePath As String
    Dim objFldr As FileDialog
    
    Set objFldr = Application.FileDialog(msoFileDialogFolderPicker)

    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False

    With objFldr
        .Title = "Select a directory"
        .AllowMultiSelect = False
        .InitialFileName = ActiveWorkbook.Path

        If .Show = True Then
            strSavePath = .SelectedItems(1)
        Else
            MsgBox "No folder selected...", vbExclamation
            Exit Sub
        End If
    End With

    Set wbSource = ActiveWorkbook

    For Each objSheet In wbSource.Sheets
        objSheet.Copy
        Set wbDest = ActiveWorkbook
        wbDest.SaveAs strSavePath & objSheet.Name, xlCSV
        wbDest.Close
    Next
    
    Application.ScreenUpdating = True

    Exit Sub

ErrorHandler:
    MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."

End Sub

Regards

 

[Pascal]

Just beat me to it!

 

[cidfidou]

Once more I am really pleased to see all the great responses from Mr Excel... Thank you all for your precious help.
Teeroy or Cytop, could you please add your code to the one of pascal as when i tried it didnt work....

I have already learned a lot today with your help... Thanks again..

 

[Pascal]

Once more I am really pleased to see all the great responses from Mr Excel... Thank you all for your precious help.
Teeroy or Cytop, could you please add your code to the one of pascal as when i tried it didnt work....

I have already learned a lot today with your help... Thanks again..

Hi,

Which code didn't work, or rather who's didn't work?

Regards

 

[Teeroy]

"It didn't work" doesn't help much with diagnosing a problem. My guess is that the filename to be saved is being concatenated to the directory name, rather than being saved in the directory, so in either Cytop's or Pascal's code try changing the line:

wbDest.SaveAs strSavePath sht.Name, xlCSV

to

wbDest.SaveAs strSavePath & "/" & sht.Name, xlCSV

 

[cidfidou]

Thanks Teeroy... it is working perfectly.. sorry for the poor english, but I tried to say that I couldnt make the code of Pascal work by adding new lines of code as i did know how to do it... Have a good a week end..

 

[cidfidou]

I went to fast as i am still getting an error messge (when I select a folder on my desktop) despite the modification of the line wbDest.SaveAs strSavePath sht.Name, xlCSV to wbDest.SaveAs strSavePath & "/" & sht.Name, xlCSV

if someone is still ready to help me, this is the code

Sub CreateWorkbooks()


Dim wbDest As Workbook
Dim wbSource As Workbook
Dim objSheet As Object
Dim strSavePath As String
Dim objFldr As FileDialog

Set objFldr = Application.FileDialog(msoFileDialogFolderPicker)


On Error GoTo ErrorHandler


Application.ScreenUpdating = False


With objFldr
.Title = "Select a directory"
.AllowMultiSelect = False
.InitialFileName = ActiveWorkbook.Path


If .Show = True Then
strSavePath = .SelectedItems(1)
Else
MsgBox "No folder selected...", vbExclamation
Exit Sub
End If
End With


Set wbSource = ActiveWorkbook


For Each objSheet In wbSource.Sheets
objSheet.Copy
Set wbDest = ActiveWorkbook
wbDest.SaveAs strSavePath & "/" & sht.Name, xlCSV
wbDest.Close
Next

Application.ScreenUpdating = True


Exit Sub


ErrorHandler:
MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."


End Sub

 

[Pascal]

Hi,

What is the Error that you're getting?

I copied the code you posted and got an error on the following line: -

wbDest.SaveAs strSavePath & "/" & sht.Name, xlCSV

It needs to be: -

wbDest.SaveAs strSavePath & "/" & objSheet.Name, xlCSV

Regards

 

[cidfidou]

Awesome Pascal!!! it is working perfectly now.... Thanks again... do you know if it is possible to get rid of the pop up window asking if we to save the change to the newly created CSV file? Asking cos I have some file with more than 20 worksheets... Thanks