Question

我的代码复制了打开的工作簿，然后使用分析月份将复制的工作簿重命名，但是我需要保存该月份的所有分析，并在文件名末尾进行序列处理。我尝试了一些简单的循环，但没有用。

            Sub NewReport()
            Dim Wb1 As Workbook
            Dim Wb2 As Workbook
            Dim dateStr As String
            Dim myDate As Date
            Dim i As Integer

            With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                .EnableEvents = False
            End With

            Set Wb1 = ActiveWorkbook

            myDate = Date

            dateStr = Format(myDate, "mmm_yyyy")

            Set Wb2 = Application.Workbooks.Add(1)
            Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
            Wb2.Sheets(Wb2.Sheets.Count).Delete
            On Error GoTo Fim
            'Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr, FileFormat:=51

            'Wb2.Close
            With Application
                .ScreenUpdating = True
                .DisplayAlerts = True
                .EnableEvents = True
            End With
        Fim:

        Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_", FileFormat:=51

        End Sub

更新

我尝试放入“ i + 1”，宏运行到版本2！但是在3日，我遇到了同样的错误，因为“ i”被重置了。假设该人没有运行50次哈哈，我最后可以做50次。有什么建议吗？

            Sub NewReport()
            Dim Wb1 As Workbook
            Dim Wb2 As Workbook
            Dim dateStr As String
            Dim myDate As Date

            i = 1

            With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                .EnableEvents = False
            End With

            Set Wb1 = ActiveWorkbook

            myDate = Date

            dateStr = Format(myDate, "mmm_yyyy")

            Set Wb2 = Application.Workbooks.Add(1)
            Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
            Wb2.Sheets(Wb2.Sheets.Count).Delete
            On Error GoTo Fim
            Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51

            'Wb2.Close
            With Application
                .ScreenUpdating = True
                .DisplayAlerts = True
                .EnableEvents = True
            End With

            Fim:
            i = i + 1
            Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51

        End Sub

Answer 1

所以，问题是如何从类似的东西中获得东西

\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21

像这样的结尾处的递增值：

\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_22

这可以通过以下步骤进行：

取字符串并用_分割。
将字符串的最后一部分加1。

Public Sub TestMe()

    Dim fileName As String
    Dim dateStr As String: dateStr = "probablySomeString"
    Dim i As Long: i = 21

    fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
            "Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i

    Debug.Print fileName
    Debug.Print Increment(fileName)

End Sub

Public Function Increment(fileName As String) As String

    Dim myResult As String
    Dim newValue As Long
    Dim myArr As Variant

    newValue = Split(fileName, "_")(UBound(Split(fileName, "_"))) + 1
    myArr = Split(fileName, "_")
    myArr(UBound(Split(fileName, "_"))) = newValue
    Increment = Join(myArr, "_")

End Function

如果初始文件如下所示：

~omum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21.xlsx然后以下示例作品：

Public Sub TestMe()

    Dim fileName As String
    Dim dateStr As String: dateStr = "probablySomeString"
    Dim i As Long: i = 21

    fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
            "Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i & ".xlsx"

    Debug.Print fileName
    Debug.Print Increment(fileName)

End Sub

Public Function Increment(fileName As String) As String

    Dim myResult As String
    Dim newValue As Long
    Dim myArr As Variant

    newValue = Split(Split(fileName, "_")(UBound(Split(fileName, "_"))), ".")(0) + 1
    myArr = Split(fileName, "_")
    myArr(UBound(Split(fileName, "_"))) = newValue
    Increment = Join(myArr, "_")
    Increment = Increment & ".xslx"

End Function

Answer 2

在google上进行了深入研究之后，我找到了一个代码并适应了我的情况。它不允许选择保存方式，它只是在同一文件夹中，但是我可以。代码上的功劳（我刚刚在名称上加上了日期）：

Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
'RESOURCE: http://www.rondebruin.nl/win/s9/win003.htm

Dim TestStr As String

'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
  On Error Resume Next
    TestStr = Dir(FilePath)
  On Error GoTo 0

'Determine if File exists
  If TestStr = "" Then
    FileExist = False
  Else
    FileExist = True
  End If

End Function

Sub SaveNewVersion_Excel()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault

Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim dateStr As String

myDate = Date

dateStr = Format(myDate, "mmm_yyyy")

TestStr = ""
Saved = False
x = 2

'Version Indicator (change to liking)
  VersionExt = "_" & dateStr & "_Rev"

'Pull info about file
  On Error GoTo NotSavedYet
    myPath = ActiveWorkbook.FullName
    myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
    FolderPath = Left(myPath, InStrRev(myPath, "\"))
    SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
  On Error GoTo 0

'Determine Base File Name
  If InStr(1, myFileName, VersionExt) > 1 Then
    myArray = Split(myFileName, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myFileName
  End If

'Test to see if file name already exists
  If FileExist(FolderPath & SaveName & SaveExt) = False Then
    ActiveWorkbook.SaveAs FolderPath & SaveName & SaveExt
    Exit Sub
  End If

'Need a new version made
  Do While Saved = False
    If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
      ActiveWorkbook.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
      Saved = True
    Else
      x = x + 1
    End If
  Loop

'New version saved
  MsgBox "New file version saved (version " & x & ")"

Exit Sub

'Error Handler
NotSavedYet:
  MsgBox "This file has not been initially saved. " & _
    "Cannot save a new version!", vbCritical, "Not Saved To Computer"

End Sub

VBA：我需要保存文件，但是如果重复，请在文件名末尾执行序列“ _1，_2，_3，...”

2 个答案: