VBA Excel 将新文件另存为活动文件的日期

Question

我有一个文件名为“ABC XXXXXX XXX XXXX Report Without XXX-XXX XXXXXXX Found 2017_11_01_071549”

我当前的 VBA 代码正在拆分工作表并将每个工作表保存为新工作簿。我需要工作簿的日期与原始工作簿相同。 2017_11_01 上面的示例。当前正在保存为 NAME_Today 的日期。

我还需要将其保存的文件夹命名为原始文件的日期。示例 2017_11_01。该代码当前保存为“书”。

下面是代码。我只运行：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

您需要一个函数来识别工作簿名称 (=string) 中的日期模式并为您提取它，以便在命名新工作簿时可以重复使用它。为此，最好的方法是使用正则表达式。我编写了一个函数来执行此操作，因此要提取您需要将其添加到代码中的日期：

将这些行添加到您的代码中：

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

提取日期函数

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