VBA Excel将新文件保存为活动文件的date

我有一个文件名“ABC XXXXXX XXX XXXX报告没有XXX-XXX XXXXXXX发现2017_11_01_071549”

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

我还需要将其保存的文件夹命名为原始文件的date。 示例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）中date的模式，并将其解压缩，以便在命名新工作簿时重用该模式。 为此，最好的方法是使用正则expression式。 我写了一个函数来做到这一点，所以要提取你需要添加到你的代码的date：

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

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

提取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