CODEWITHSUNDEEP
excelsavefilenamesvba
hispeedzintarwebz
hispeedzintarwebz

Reputation: 9

VBA - Saving all worksheets as separate files with a file name based on a cell

I've found code to save all the worksheets, and I've found code to save the file with a filename based on a cell, but I can't seem to get both to work at the same time. Below is my entire macro - but the problem seems to stem from the last section: Sub(SheetSplit). I've tried all sorts of methods I've found online, but I need this to happen with a relative path - as in the same folder in which the workbooks are. The code is in a workbook called "Remit Macros.xls" and the multi-tabbed workbook I'm messing with is "RemitReport.xls" - what am I missing here? I always get an error of "Method 'SaveAs' of object '_Workbook' failed. What gives? I included the rest of the code in case it helps.

Sub RemitTotal()
    '
    ' Highlights remit amounts great enough for additional approvals
    '
    Workbooks.Open (ThisWorkbook.Path & "\RemitReport.xls")
    Windows("RemitReport.xls").Activate

    Dim i As Long
    For i = 1 To Worksheets.Count
        Sheets(i).Select

        BeginRow = 6
        EndRow = Range("A1000").End(xlUp).Row
        ChkCol = 18

        For RowCnt = BeginRow To EndRow - 9
            If Cells(RowCnt, ChkCol).Value > 500000 Then
                Range("R6:R1000").Select
                With Selection.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
                End With
            End If
        Next RowCnt
    Next i

    Call DateMacro

End Sub

Sub DateMacro()
    '
    ' Highlights dates not in the current month, i.e. early or late payments
    '
    Windows("RemitReport.xls").Activate

    Dim i As Long
    For i = 1 To Worksheets.Count
        Sheets(i).Select

        BeginRow = 6
        EndRow = Range("A1000").End(xlUp).Row
        ChkCol = 6

        For RowCnt = BeginRow To EndRow - 9
            If IsDate(Cells(RowCnt, ChkCol)) And Month(Date) <> Month(Cells(RowCnt, ChkCol - 1).Value) Then
                'date values no longer need to be updated monthly
                Cells(RowCnt, ChkCol - 1).Select
                With Selection.Interior
                .ColorIndex = 10
                .Pattern = xlSolid
                End With
            End If
        Next RowCnt

        BeginRow = 6
        EndRow = Range("A1000").End(xlUp).Row
        ChkCol = 6

        For RowCnt = BeginRow To EndRow - 9
            If Cells(RowCnt, ChkCol).Value = Cells(RowCnt, ChkCol - 1) + 30 Then
                Cells(RowCnt, ChkCol).Select
                With Selection.Interior
                    .ColorIndex = 0
                    .Pattern = xlSolid
                End With
            End If
        Next RowCnt
    Next i

    Call RemitNames

End Sub

Sub RemitNames()
    '
    'Adds lender remit name in the active worksheets in order to facilitate
    'saving each sheet under a different filename indicative of lender
    '
    Dim i As Long
    For i = 1 To Worksheets.Count
        Sheets(i).Select

        Range("A65536").End(xlUp).Select
        Selection.Copy
        Application.CutCopyMode = False
        Selection.Copy
        Range("D1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("E1").Select

        ActiveCell.Formula = "=RIGHT(D1,LEN(D1)-FIND("": "",D1))"
        Range("F1").Formula = "=TRIM(E1)"
        Range("D3:S3").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        Range("J1").Formula = "=INDEX('[Remit Macros.xls]Remit Codes'!$B1:$B999,MATCH(F1,'[Remit Macros.xls]Remit Codes'!$A1:$A999,0))"
        Range("J1").Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("D1:F1").Select
        Selection.ClearContents
        Range("J1").Select

    Next i

    Call SheetSplit

End Sub

Sub SheetSplit()
    '
    'Creates an individual workbook for each worksheet in the active workbook.
    '
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Object
    Dim strSavePath As String
    Dim sname As String
    Dim relativePath As String

    Set wbSource = ActiveWorkbook

    For Each sht In wbSource.Sheets

        sht.Copy
        Set wbDest = ActiveWorkbook

        sname = ThisWorkbook.ActiveSheet.Range("A1") & ".xls"
        relativePath = Application.ActiveWorkbook.Path & "\" & sname
        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        ActiveWorkbook.SaveAs FileName:=relativePath, FileFormat:=xlExcel8
        Application.DisplayAlerts = True

        Range("A1").Clear

    Next

    MsgBox "Done!"

End Sub

Edit: After several of the suggestions I've been given, here is the last section of the code. It still doesn't work, but I think it's getting closer. I've also cleaned it up a little bit.

Sub SheetSplit()
'Creates an individual workbook for each worksheet in the active workbook.
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object
Dim strSavePath As String
Dim sname As String
Dim origpath As String
Dim relativePath As String
Set wbSource = ActiveWorkbook
    origpath = wbSource.Path
    'relativePath = origpath & "\" & sname
    'sname = sht.Range("A1") & ".xls"
        For Each sht In wbSource.Sheets
            sht.Copy
            Set wbDest = ActiveWorkbook
            sname = sht.Range("A1") & ".xls"
            relativePath = origpath & "\" & sname
            'relativePath = Application.ActiveWorkbook.Path & "\" & sname
            Application.DisplayAlerts = False
            ActiveWorkbook.CheckCompatibility = False
            ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=56
            Application.DisplayAlerts = True
'Range("A1").Clear
Next
MsgBox "Done!"
End Sub

Upvotes: 0

Views: 11171

Answers (2)

Ross McConeghy
Ross McConeghy

Reputation: 874

Try this, see comments in the code.

Sub SheetSplit()
    '
    'Creates an individual workbook for each worksheet in the active workbook.
    '
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sht As Object
    Dim strSavePath As String
    Dim sname As String
    Dim relativePath As String

    Set wbSource = ActiveWorkbook

    For Each sht In wbSource.Sheets

        sht.Copy
        Set wbDest = ActiveWorkbook

        sname = sht.Range("A1") & ".xls"
        relativePath = wbSource.Path & "\" & sname 'use path of wbSource

        wbDest.Sheets(1).Range("A1").Clear 'clear filename from new workbook cell A1

        Application.DisplayAlerts = False
        ActiveWorkbook.CheckCompatibility = False
        ActiveWorkbook.SaveAs FileName:=relativePath, FileFormat:=xlExcel8
        Application.DisplayAlerts = True


        wbDest.Close False 'close the newly saved workbook without saving (we already saved)

    Next

    MsgBox "Done!"

End Sub

Upvotes: 1

Alistair Weir
Alistair Weir

Reputation: 1849

When the new workbook is created it has not yet been saved so relative path is just \sname so it can't save.

Move the relative pathline above the creation of the new book so:

Dim origpath as string, relativePath As String

Set wbSource = ActiveWorkbook
origpath = wbSource.path

Then

relativePath = origpath & "\" & sname

You also need to change the sheetname line to:

sname = sht.Range("A1") & ".xls"

And you probably want to close each new book after it has been created or depending on the number of sheets in your original workbook you will have a lot of workbooks open:

wbDest.close

One final thing is you should be explicit about which Range("A1") you are clearing or it could also cause an error if removed from source wb as the next sheetname would be blank

Upvotes: 0

Related Questions