VBA Excel Macro save as part of cell with date

0
votes

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?

2
vbaexcelsave
1. If you copy a worksheet to no destination, you end up with a new (active) workbook with a copy of that worksheet as the only worksheet. 2. It should be a simple matter to use VBA, worksheet functions or even regex to extract JDOE from the string in A1 and append the current date to it. What part of substring extraction are you having trouble with? – user4039065
btw,is your default Save files in this format: really set to .XLS? – user4039065
1. This is correct – cmpmd2
2. Yes it is saving as .xls. I'm having trouble with extracting the JDOE name and adding the date to new workbook save name. Its saving as Sheet1. sheet2 etc. – cmpmd2

2 Answers

0
votes

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
0
votes

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