Как сохранить активную книгу в другой папке в Excel VBA?

Question

Я пытаюсь автоматически сохранить свою активную книгу в другую папку на моем компьютере, и если в этой папке уже есть файл с именем моей книги, его следует сохранить с помощью «_v1» / «_ v2» и т. Д. в конце его имени.
Я нашел этот код, но он работает только для текущей папки, в которой сохранена книга.

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

Вы можете переместить все логи c в отдельную функцию, тогда вам нужно только вызвать ее, чтобы получить «правильное» имя для сохранения в виде.

'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