VBA Excel Save new file as date of active file

Question

I have a file name of "ABC XXXXXX XXX XXXX Report Without XXX-XXX XXXXXXX Found 2017_11_01_071549"

My current VBA code is splitting out the worksheets and saving each sheet as a new workbook. I need the date of the workbook to be the same as the original workbook. Example from above 2017_11_01. Is currently saving as NAME_Today's date.

I also need to name the folder its saving to the date of the original file. Example 2017_11_01. The code is currently saving as "Book".

Below is the code. I only run: Sub OpenLatestFile()

Sub SaveShtsAsBook()
'
' SaveShtsAsBook Macro
' Splits out the sheets and saves them to their own file with date appended
'
Dim ldate As String
Dim SheetName1 As String
Dim ParentFolder As String
ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&

ParentFolder = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 1)
ParentFolder = Right(ParentFolder, 10)

MyFilePath$ = ActiveWorkbook.Path & "\" & ParentFolder & "\"
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
     '      End With
    On Error Resume Next '<< a folder exists

    'need to change variable to the date here
    MkDir MyFilePath '<< create a folder

    For N = 2 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


Sub OpenLatestFile()

'
' OpenLatestFile Macro
' Opens the latest file specified in the specified folder
'
    'Declare the variables
    Dim MyPath As String
    Dim MyFile As String
    Dim LatestFile As String
    Dim ArchivePath As String
    Dim LatestDate As Date
    Dim LMD As Date

    'Specify the path to the folder
    'MyPath = "c:\temp\excel"

    'Make sure that the path ends in a backslash
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"

    'Get the first Excel file from the folder
    MyFile = Dir(MyPath & "*.xls", vbNormal)

    'If no files were found, exit the sub
    If Len(MyFile) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If

    'Loop through each Excel file in the folder
    Do While Len(MyFile) > 0

        'Assign the date/time of the current file to a variable
        LMD = FileDateTime(MyPath & MyFile)

        'If the date/time of the current file is greater than the latest
        'recorded date, assign its filename and date/time to variables
        If LMD > LatestDate Then
            LatestFile = MyFile
            LatestDate = LMD
        End If

        'Get the next Excel file from the folder
        MyFile = Dir

    Loop

    'Open the latest file
    Workbooks.Open MyPath & LatestFile

    Call SaveShtsAsBook
    Application.Goto Reference:="OpenLatestFile"
End Sub

Answer 1

You need a function to recognize the pattern of the date in the workbook name (=string) and extract it for you so that you can reuse it when naming the new workbooks. For that, the best approach is using Regular Expressions. I wrote a function that will do that, so to extract the date you need to add this to your code:

Add these lines to your code:

 dim sDate as string
sDate=ExtractDate(ActuiveWorkbook.Name)

Function to Extract the Date

Function ExtractDate(str As String, Optional iOrderOfMatch As Integer = 1) As String
'Extracts a matching string (with the pattern provided in the function)
'To extract the last match use -1 as the order, otherwise provide the order of match
'Default order is the first match (=1). In case of any bad entry for the order, first match will be returned
'If there is no match, a zero-length string will be returned
    Dim iMatchCount  As Integer
    Dim strPattern As String: strPattern = "(\d{4}_\d{1,2}_\d{1,2})"
    Dim matches As Object
    Dim match As Variant
    Dim regEx As Object

    Set regEx = CreateObject("VBScript.RegExp")

    'Define parameters
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern
    End With

    'Get the matches if there is any
    If regEx.Test(str) Then
        Set matches = regEx.Execute(str)
        iMatchCount = matches.Count 'number of matches in the input string

'        For Each match In matches
'            Debug.Print match.Value
'        Next match

        Select Case iMatchCount
            Case 0
               ExtractDate = ""
            Case 1
                ExtractDate = matches.Item(0)
            Case Else
                On Error GoTo Handler
                If iOrderOfMatch < 0 Then
                    ExtractDate = matches.Item(iMatchCount - 1)
                Else
                    ExtractDate = matches.Item(iOrderOfMatch - 1)
                End If
        End Select
    End If

    Exit Function

 Handler:
    ExtractDate = matches.Item(0)
End Function