VBA Excel宏保存为带有日期的单元格的一部分

Question

我有以下 VBA 代码将 workbook1 工作表保存到保存 workbook1 文件的文件夹中。示例：workbook1 有 31 张工作表。该代码将每个工作表保存到与工作表同名的新工作簿中。 （Sheet1、Sheet2 等）。

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

我需要修改代码以保存带有 ID 和日期的文件。 ID 在单元格 A1 中。 “Doe, John (JDOE) 的 XXX Clinic Pro 费用报告”。在此示例中，我需要将新工作簿另存为 JDOE_2017-10-20。

有没有办法给出 ID 并在其后面加上日期？

Answer 1

试试下面的代码

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

Answer 2

您可以从括号中提取名称代码，并在日期后面附加几行代码。

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

以及其他一些修改，

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