Exporting Excel Sheet with File Name

[ad1237]

Hi,

I currently have a macro that runs on all Excel files in a folder and exports all the sheets within those files out as a csv.

I'd like to know if it's possible run the macro so that these csv files that are created are saved with sheet name and prefix : first 6 letters of the original Excel file name.

For example:

File 1 name : 123456 ABC ABC and sheets are called XYZ, GHB, TBA
File 2 name: 456789 ABC ABC and sheets are called XYZ, GHB, TBA

Instead of output being same copies of XYZ, GHB, TBA csv file names, I'd like them to be as "123456 XYZ.csv", "123456 GHB.csv", "456789 XYZ.csv", etc.

Below is the code that exports sheet to csv:
Sub ExportSheetsToCSV()
Dim xWs As Worksheet
Dim xcsvFile As String
ChDrive "C"
ChDir "C:\Users\_____"
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.Copy
xcsvFile = CurDir & "\" & xWs.Name & ".csv"
Application.ActiveWorkbook.SaveAs fileName:=xcsvFile, _
FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Saved = True
Application.ActiveWorkbook.Close
Next
End Sub

 

[Z51]

Not tested, but perhaps something like:
xcsvFile = CurDir & "\" & Left(ActiveWorkbook.Name, 6) & xWs.Name & ".csv"

 

[ad1237]

Not tested, but perhaps something like:
xcsvFile = CurDir & "\" & Left(ActiveWorkbook.Name, 6) & xWs.Name & ".csv"

Unfortunately it didn't work. if I put in just ActiveWorkbook, instead of getting workbook name as prefix I'm getting :

Instead of : "123456 XYZ.csv", "123456 GHB.csv", "456789 XYZ.csv"

I'm getting: "Book1 XYZ.csv", "Book2 GHB.csv", "Book3 XYZ.csv"

Sharing my entire code if it helps, macro runs through ALL the workbooks within a subfolder:

Sub Macro1()
Call RecursiveFolders("C:\Users\_________")
End Sub

Sub RecursiveFolders(ByVal MyPath As String)

Dim FileSys As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFile As Object
Dim wkbOpen As Workbook

Set FileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = FileSys.GetFolder(MyPath)

Application.ScreenUpdating = False

For Each objSubFolder In objFolder.SubFolders
For Each objFile In objSubFolder.Files
Set wkbOpen = Workbooks.Open(fileName:=objFile)
Call ExportSheetsToCSV
wkbOpen.Close SaveChanges:=True
Next
Call RecursiveFolders(objSubFolder.Path)
Next

Application.ScreenUpdating = True

End Sub

Sub ExportSheetsToCSV()
Dim xWs As Worksheet
Dim xcsvFile As String
ChDrive "C"
ChDir "C:\Users\___________"
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.Copy
xcsvFile = CurDir & "\" & ActiveWorkbook.FullName & xWs.Name & ".csv"
Application.ActiveWorkbook.SaveAs fileName:=xcsvFile, _
FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Saved = True
Application.ActiveWorkbook.Close
Next
End Sub