如何将活动工作簿保存在 Excel VBA 的另一个文件夹中？

Question

我正在尝试将我的活动工作簿自动保存到我计算机上的另一个文件夹中，如果该文件夹中已经有一个以我的工作簿名称命名的文件，那么它应该使用“_v1”/“_v2”等保存on 在其名称的末尾。
我找到了这段代码，但它只适用于保存工作簿的当前文件夹。

Sub SaveNewVersion_Excel()
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

TestStr = ""
Saved = False
x = 2

VersionExt = "_v"

On Error GoTo NotSavedYet
    myPath = "O:\Operations\Department\Data Bank Coordinator\_PROJECTS_\QC BeadRegion Check\Multi Ref Archiv"
    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

If InStr(1, myFileName, VersionExt) > 1 Then
    myArray = Split(myFileName, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myFileName
  End If

If FileExist(FolderPath & SaveName & SaveExt) = False Then
    ActiveWorkbook.saveAs FolderPath & SaveName & SaveExt
    Exit Sub
  End If

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
Exit Sub

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


Function FileExist(FilePath As String) As Boolean

Dim TestStr As String

  On Error Resume Next
    TestStr = Dir(FilePath)
  On Error GoTo 0

  If TestStr = "" Then
    FileExist = False
  Else
    FileExist = True
  End If

End Function

它适用于当前文件夹，但是当我更改文件夹路径时它不起作用。 如果您能帮助我，我将不胜感激。

谢谢！
塞尔吉乌

Answer 1

我假设新文件夹是“D:_PROJECTS_\Multi Ref Archiv”，如果现有文件是 zzzz_v07.xlsm，那么即使文件夹中没有以前的版本，您也希望将其保存为 zzzz_v08.xlsm。我添加了前导零，以便它们很好地排序！

Sub SaveNewVersion_Excel2()

    Const FOLDER = "D:\_PROJECTS_\Multi Ref Archiv" ' new location
    Const MAX_FILES = 99

    Dim oFSO As Object, oFolder As Object, bOK As Boolean, res As Variant
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Dim sFilename As String, sFilename_v As String

    ' filename only
    sFilename = ThisWorkbook.Name

    ' check folder exists
    If Not oFSO.folderexists(FOLDER) Then
        bOK = MsgBox(FOLDER & " does not exist. Do you want to create ?", vbYesNo, "Confirm")
        If bOK Then
            oFSO.createFolder FOLDER
            MsgBox "OK created " & FOLDER, vbInformation
        Else
            Exit Sub
        End If
    End If

    ' get next name
    sFilename_v = Next_v(sFilename)

    ' check if exists
    Dim i As Integer: i = 1
    Do While oFSO.fileexists(FOLDER & "\" & sFilename_v) = True And i <= MAX_FILES
        i = i + 1
        sFilename_v = Next_v(sFilename_v)
    Loop

    ' check loop ok
    If i > MAX_FILES Then
        MsgBox "More than " & MAX_FILES & " files already exist", vbExclamation
        Exit Sub
    End If
    sFilename_v = FOLDER & "\" & sFilename_v

    ' confirm save
    res = MsgBox("Do you want to save to " & sFilename_v, vbYesNo, "Confirm")
    If res = vbYes Then
        ActiveWorkbook.SaveAs sFilename_v
        MsgBox "Done", vbInformation
    End If

End Sub

Function Next_v(s As String)

    Const ver = "_v"
    Dim i As Integer, j As Integer, ext As String, rev As Integer

    i = InStrRev(s, ".")
    j = InStrRev(s, ver)
    ext = Mid(s, i)

    ' increment existing _v if exists
    If j > 0 Then
        rev = Mid(s, j + 2, i - j - 2)
        s = Left(s, j - 1)
    Else
        rev = 0
        s = Left(s, i - 1)
    End If
    Next_v = s & ver & Format(rev + 1, "00") & ext

End Function

Answer 2

您可以将所有逻辑移出到一个单独的函数中，然后您只需要调用它来获取“正确”的名称以另存为。

'Pass in the full path and filename
' Append "_Vx" while the passed filename is found in the folder
' Returns empty string if the path is not valid
Function NextFileName(fPath As String)
    Const V As String = "_V"
    Dim fso, i, p, base, ext

    Set fso = CreateObject("scripting.filesystemobject")
    'valid parent folder?
    If fso.folderexists(fso.GetParentFolderName(fPath)) Then
        p = fPath
        ext = fso.getextensionname(p)
        base = Left(p, Len(p) - (1 + Len(ext))) 'base name without extension
        i = 1
        Do While fso.fileexists(p)
            i = i + 1
            p = base & (V & i) & "." & ext
        Loop
    End If
    NextFileName = p
End Function