Sheet Export Macro to Flat File

[JPSIMMON]

I use this code to export my worksheets to a folder as separate flat files, so none of the formulas or references carry over, just the values.
It doesn't seem to work, it is only exporting the first worksheet.

Sub CreateWorkbooks()
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object
Dim strSavePath As String
Dim r As Long, c As Long, ws As Worksheet
On Error GoTo ErrorHandler

Application.ScreenUpdating = False


strSavePath = "S:\yyyyyyy\vvvvv\xxx\"


Set wbSource = ActiveWorkbook


For Each sht In wbSource.Sheets
r = sht.Rows.Find("*", , , , xlByRows, xlPrevious).Row
c = sht.Columns.Find("*", , , , xlByColumns, xlPrevious).Column
sht.Copy
Set ws = ActiveSheet
ws.Range("A1").Resize(r, c).Value = sht.Range("A1").Resize(r, c).Value
Set wbDest = ActiveWorkbook
wbDest.SaveAs strSavePath & sht.Name
wbDest.Close
Next

Application.ScreenUpdating = True

ErrorHandler:

End Sub

[xladept]

Maybe:

Sub CreateWorkbooks() 'JP Simmon
Dim wbDest As Workbook, wbSource As Workbook: Set wbSource = ActiveWorkbook
Dim sht As Worksheet, ws As Worksheet
Dim strSavePath As String, r As Long, c As Long: strSavePath = "S:\yyyyyyy\vvvvv\xxx\"

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
For Each sht In wbSource.Sheets
r = sht.Rows.Find("*", , , , xlByRows, xlPrevious).Row
c = sht.Columns.Find("*", , , , xlByColumns, xlPrevious).column
Workbooks.Add
Set wbDest = ActiveWorkbook: Set ws = ActiveSheet
ws.Range("A1").Resize(r, c).value = sht.Range("A1").Resize(r, c).value
wbDest.SaveAs strSavePath & sht.Name
wbDest.Close False
Next
ErrorHandler:
Application.ScreenUpdating = True
End Sub

[JPSIMMON]

Thank you for the help,

Still not exporting tabs into folder though

[xladept]

Well then maybe:

Sub CreateWorkbooks() 'JP Simmon
Dim wbDest As Workbook, wbSource As Workbook: Set wbSource = ActiveWorkbook
Dim sht As Worksheet, ws As Worksheet
Dim strSavePath As String, r As Long, c As Long: strSavePath = "S:\yyyyyyy\vvvvv\xxx\"

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
For Each sht In wbSource.Sheets
sht.copy
Set wbDest = ActiveWorkbook
wbDest.SaveAs strSavePath & sht.Name
wbDest.Close False
Next
ErrorHandler:
Application.ScreenUpdating = True
End Sub

[JPSIMMON]

Thanks dept. It is exporting the separate files with the formulas, anyway I can flatten them to just have values?

[xladept]

Hi JP,

Thanks for the rep!

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

[xladept]

Hopefully,

Sub CreateWorkbooks() 'JP Simmon
Dim wbDest As Workbook, wbSource As Workbook: Set wbSource = ActiveWorkbook
Dim sht As Worksheet, ws As Worksheet
Dim strSavePath As String, r As Long, c As Long: strSavePath = "S:\yyyyyyy\vvvvv\xxx\"

On Error GoTo ErrorHandler

Application.ScreenUpdating = False
For Each sht In wbSource.Sheets
sht.copy

Set wbDest = ActiveWorkbook: Set ws = ActiveSheet
ws.Cells.copy
ws.Range("A1").PasteSpecial xlPasteValues

wbDest.SaveAs strSavePath & sht.Name
wbDest.Close False
Next
ErrorHandler:
Application.ScreenUpdating = True
End Sub