VBA Excel Macro save as part of cell with date

Question

I have the following VBA code saving workbook1 sheets to a folder where workbook1 file is saved. Example: workbook1 has 31 sheets. The code saves each sheet to a new workbook with the same name as the sheet. (Sheet1, Sheet2, etc).

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
     '      End With
    On Error Resume Next '<< a folder exists
    MkDir MyFilePath '<< create a folder
    For N = 1 To Sheets.Count
        Sheets(N).Activate
        SheetName = ActiveSheet.Name
        Cells.Copy
        Workbooks.Add (xlWBATWorksheet)
        With ActiveWorkbook
            With .ActiveSheet
                .Paste
                .Name = SheetName
                [A1].Select
            End With
             'save book in this folder
            .SaveAs Filename:=MyFilePath _
            & "\" & SheetName & ".xls"
            .Close SaveChanges:=True
        End With
        .CutCopyMode = False
    Next
End With
Sheet1.Activate
End Sub

I need to modify the code to save the file with the ID and date. The ID is in cell A1. "XXX Clinic Pro Fees Report for Doe, John (JDOE)". In this example I need the new workbook to save as JDOE_2017-10-20.

Is there a way to gave the ID and place the date after it?

Answer 1

You can extract the name code from within the brackets and append the date with a couple lines of code.

    SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
    SheetName = sn & Format(Date, "_yyyy-mm-dd")

Along with a couple other modifications as,

Option Explicit

Sub SaveShtsAsBook()
    Dim ws As Worksheet, sn As String, mfp As String, n As Long

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    On Error Resume Next '<< a folder exists
    mfp = ActiveWorkbook.Path & "\" & Split(ThisWorkbook.Name, Chr(46))(0)
    MkDir mfp '<< create a folder
    On Error GoTo 0 '<< resume default error handling

    With ActiveWorkbook
        For n = 1 To .Worksheets.Count
            With .Worksheets(n)
                sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
                sn = sn & Format(Date, "_yyyy-mm-dd")
                .Copy
                With ActiveWorkbook
                     'save book in this folder
                    .SaveAs Filename:=mfp & "\" & sn, FileFormat:=xlExcel8
                    .Close SaveChanges:=False
                End With
            End With
        Next
    End With

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Answer 2

Try the below code

Sub SaveShtsAsBook()
Dim ldate As String
Dim SheetName1 As String


ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
     '      End With
    On Error Resume Next '<< a folder exists
    MkDir MyFilePath '<< create a folder
    For N = 1 To Sheets.Count
        Sheets(N).Activate
        SheetName = ActiveSheet.Name
        Cells.Copy
        SheetName1 = Range(A1).Value2 & ldate
        Workbooks.Add (xlWBATWorksheet)

        With ActiveWorkbook
            With .ActiveSheet
                .Paste
                .Name = SheetName
                [A1].Select
            End With
            tempstr = Cells(1, 1).Value2
            openingParen = InStr(tempstr, "(")
            closingParen = InStr(tempstr, ")")
            SheetName1 = Mid(tempstr, openingParen + 1, closingParen - openingParen - 1) & "_" & ldate
             'save book in this folder
            .SaveAs Filename:=MyFilePath _
            & "\" & SheetName1 & ".xls"
            .Close SaveChanges:=True
        End With
        .CutCopyMode = False
    Next
End With
Sheet1.Activate
End Sub