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中。 “约翰·多伊（XXX）的XXX诊所专业费用报告（JDOE）”。 在此示例中，我需要将新工作簿另存为JDOE_2017-10-20。

有没有办法提供ID并在其后放置日期？

Answer 1

您可以从方括号内提取名称代码，并在日期后加上几行代码。

    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

Answer 2

试试下面的代码

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