Parse Functions‎ > ‎

Sheets to WB(2)

  1. Open all workbooks in a specific folder one at a time
  2. Save each sheet in each workbook as a separate file to a separate directory
  3. The names equal the worksheet names themselves plus a unique counter added to the end
    (e.g. Sheet1-0001.xls, Sheet2-0002.xls, etc.)
  4. Do NOT save the last sheet in the all others
  5. NOTE:  The SaveAs command for Excel 2007+ is more detailed.  Choose the correct SaveAs command for your version of Excel.


Sub SaveAllSheetsFromWBsInFolder()
'Jerry Beaucaire  (11/4/2009)
'Open all .XLS and save each sheet separately with unique name
Dim fName As String, fPath As String, fPathOut As String
Dim wbkOld As Workbook, ws As Worksheet, Cntr As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

fPath = "C:\Matter Logs\"              'do not forget the final \ in this string
fPathOut = fPath & "Reports\"         
'do not forget the final \ in this string

fName = Dir(fPath & "*.xls")
Cntr = 1                               'the unique counter

    Do While Len(fName) > 0
        Set wbkOld = Workbooks.Open(fPath & fName)
        For Each ws In Worksheets
            If ws.Index < Sheets.Count Then ws.Move
            ActiveWorkbook.SaveAs fPathOut & ActiveSheet.Name & "-" & Format(Cntr, "0000"), FileFormat:=xlNormal
            'ActiveWorkbook.SaveAs fPathOut & ActiveSheet.Name & "-" & Format(Cntr, "0000") & ".xlsx", FileFormat:=52   'for Excel 2007+
            Cntr = Cntr + 1
        Next ws
        fName = Dir
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!