save multiple worksheets as individual CSV files through VBA

[Andre]

Hello,

I have just started dabbling in macros, but I am not yet to the level that I
wish to be able to do this:

I have a excel spreadsheet with 5 tabs, named Journal01, journal02, etc

In each of the sheets, I have in cell C2 data that will eventually become
the name of the CVS file I wish to save for that particular sheet.
For example in sheet JOURNAL01, I have in cell C2 the data XX3105
JOURNAL02, I have in cell C2 the data
XX3106

I want to create a macro that will save the sheet Journal01 as
XX3105.CSV, in a directory C:\TEMP, then move to Sheet journal02 and save
that one as XX3106.csv in the same directory, and continue on for my 5
sheets all in one go.

Can anyone help, please

Thanks in advance

André

[Dave Peterson]

One way:

Option Explicit
Sub testme03()

Dim testWks As Worksheet
Dim iCtr As Long

Dim wksBaseName As String
Dim FolderName As String
Dim testStr As String

wksBaseName = "Journal"

FolderName = "C:\temp\"
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If

testStr = ""
On Error Resume Next
testStr = Dir(FolderName & "nul")
On Error GoTo 0
If testStr = "" Then
MsgBox "That folder is not available"
Exit Sub
End If

For iCtr = 1 To 5
Set testWks = Nothing
On Error Resume Next
Set testWks = Worksheets(wksBaseName & Format(iCtr, "00"))
On Error GoTo 0

If testWks Is Nothing Then
MsgBox "something's wrong with " & wksBaseName & Format(iCtr, "00")
Else
testWks.Copy 'copies to new workbook
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
Filename:=FolderName & ActiveSheet.Range("c2").Value, _
FileFormat:=xlCSV
If Err.Number <> 0 Then
MsgBox "something went wrong with Journal " _
& Format(iCtr, "00") & ".csv"
Err.Clear
End If
Application.DisplayAlerts = True
On Error GoTo 0
ActiveWorkbook.Close savechanges:=False
End If
Next iCtr

End Sub

If there's an existing file with the same name, it's overwritten.

And I'm not sure if I'd use c:\temp to store anything that should be kept. I
clean up my temp folders when ever I want with no thought of what's there.
(This may not be your windows temp folder, but if you do the same, you may want
to put the files in a spot that looks more permanent.)

--

Dave Peterson
ec3...@msn.com

[Andre]

Hi Dave !

I am totally and utterly impressed. Already tested and it works great.
Another sub question: what if the my sheet names numbers are Journal01,
Journal 29, Journal 43, journal78, journal95? (instead of 01 to 05)
Is it easy to fix? I would like to be able to alter them depending of my
file

What a great motivation for me to learn more.

Thank you for your prompt response, it looks as if this did not take you
more then 5 minutes!!!

Merci!
André
A French Canadian living in Australia.

"Dave Peterson" <ec3...@msn.com> wrote in message
news:3EF59DC...@msn.com...

[Dave Peterson]

I don't see a pattern for the worksheet names.

Since there are a few, you could just make a list and cycle through that list:

Option Explicit
Sub testme03()

Dim testWks As Worksheet
Dim iCtr As Long

Dim myWksNames As Variant

Dim FolderName As String
Dim testStr As String

myWksNames = Array("journal12", "journal23", "journal41", "Not Journal11")

FolderName = "C:\temp\"
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If

testStr = ""
On Error Resume Next
testStr = Dir(FolderName & "nul")
On Error GoTo 0
If testStr = "" Then
MsgBox "That folder is not available"
Exit Sub
End If

For iCtr = LBound(myWksNames) To UBound(myWksNames)

Set testWks = Nothing
On Error Resume Next

Set testWks = Worksheets(myWksNames(iCtr))

On Error GoTo 0

If testWks Is Nothing Then

MsgBox "something's wrong with " & myWksNames(iCtr)

Else
testWks.Copy 'copies to new workbook
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
Filename:=FolderName & ActiveSheet.Range("c2").Value, _
FileFormat:=xlCSV
If Err.Number <> 0 Then

MsgBox "something went wrong with " & myWksNames(iCtr)

Err.Clear
End If
Application.DisplayAlerts = True
On Error GoTo 0
ActiveWorkbook.Close savechanges:=False
End If
Next iCtr

End Sub

======
But if those names change often, I think I'd click on the first worksheet tab
and ctrl-click on subsequent (group them). Then run the macro against that set
of grouped worksheets.

Option Explicit
Sub testme03()

Dim wks As Worksheet
Dim iCtr As Long
Dim mySheets As Sheets

Dim FolderName As String
Dim testStr As String

'if you always have more than one.
'delete if you want just the selected sheet
If ActiveWindow.SelectedSheets.Count = 1 Then
MsgBox "Please select more than one sheet"
Exit Sub
End If

Set mySheets = ActiveWindow.SelectedSheets

FolderName = "C:\temp\"
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If

testStr = ""
On Error Resume Next
testStr = Dir(FolderName & "nul")
On Error GoTo 0
If testStr = "" Then
MsgBox "That folder is not available"
Exit Sub
End If

For Each wks In mySheets
wks.Copy 'copies to new workbook

On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
Filename:=FolderName & ActiveSheet.Range("c2").Value, _
FileFormat:=xlCSV
If Err.Number <> 0 Then

MsgBox "something went wrong with " & wks.Name

Err.Clear
End If
Application.DisplayAlerts = True
On Error GoTo 0
ActiveWorkbook.Close savechanges:=False

Next wks

End Sub

I deleted that part that checked to see if the sheet existed. (Since you
selected them, it shouldn't disappear!)

--

Dave Peterson
ec3...@msn.com