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

Posted 2023-05-07

【中文标题】VBA Excel宏保存为带有日期的单元格的一部分

【英文标题】：VBA Excel Macro save as part of cell with date

【发布时间】：2017-11-20 23:25:31

【问题描述】：

我有以下 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 并在其后面加上日期？

【问题讨论】：

1.如果您将工作表复制到任何目的地，您最终会得到一个新的（活动的）工作簿，该工作表的副本作为唯一的工作表。 2.使用VBA，工作表函数甚至正则表达式从A1中的字符串中提取JDOE并将当前日期附加到它应该是一件简单的事情。您在提取子字符串的哪一部分遇到问题？

顺便说一句，您的默认以这种格式保存文件： 真的设置为.XLS吗？

1.这是正确的

2.是的，它保存为 .xls。我在提取 JDOE 名称并将日期添加到新工作簿保存名称时遇到问题。将其另存为 Sheet1。 sheet2等

【参考方案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

【讨论】：

代码未将新工作簿保存为“JDOE_2017_11_20”。

它保存为什么？理想情况下，它会从相应工作表的 A1 中提取括号内的值

【参考方案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

【讨论】：

代码停在 sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)。是另一种说法吗？我对拆分功能不熟悉。

我想你让大家相信 'XXX Clinic Pro Fees Report for Doe, John (JDOE)' 位于要导出的每个工作表的 A1 单元格中。顺便说一句，有关 VBA 拆分功能的帮助可在 msdn.microsoft.com 上获得。

我可能错过了.（参见上面的编辑）。您应该检查一下 ThisWorkbook 和 ActiveWorkbook 的一些混淆。

它在 A1 中。谢谢