Question

我在下面的宏中保存了一个带有修订号/日期和时间戳的文件。分配给宏按钮时，此工作正常。第一次保存文件时，它会创建Rev001。但是，当相同的宏应用于电子表格上的命令按钮时，它不会将文件保存为Rev001，而是从前一个文件编号继续。

任何想法都会受到赞赏。

Sub SaveNumberedVersion()

Dim strVer As String
Dim strDate As String
Dim strPath As String
Dim strNewPath As String
Dim strFile As String
Dim strOldFilePath As String
Dim oVars As Variant
Dim strFileType As Integer
Dim strVersionName As String
Dim intPos As Long
Dim sExt As String
Dim wb As Workbook
Dim strNewFolderName As String

Set oVars = ActiveWorkbook.CustomDocumentProperties

strDate = Format((Date), "dd MMM yyyy")
strOldFilePath = ActiveWorkbook.FullName
strNewFolderName = "Superseded"

strPath = ActiveWorkbook.Path

    If Len(Dir(strPath & "\" & strNewFolderName, vbDirectory)) = 0 Then
        MkDir (strPath & "\" & strNewFolderName)
    End If


With ActiveWorkbook
    On Error GoTo CancelledByUser
    If Len(.Path) = 0 Then 'No path means document not saved
        .Save 'So save it
    End If
    strPath = .Path 'Get path
    strFile = .Name 'Get document name


End With

intPos = InStr(strFile, " - ") 'Mark the version number
sExt = Right(strFile, Len(strFile) - InStrRev(strFile, ".xl"))



If intPos = 0 Then 'No version number
    intPos = InStrRev(strFile, ".xl") 'Mark the extension instead
End If

strFile = Left(strFile, intPos - 1) 'Strip the extension or version number

Select Case LCase(sExt) 'Determine file type by extension
    Case Is = "xlsx"
        strFileType = 51
    Case Is = "xlsm"
        strFileType = 52
    Case Is = "xlsb"
        strFileType = 50
    Case Is = "xls"
        strFileType = 56
    'Case Is = "dotx"
        'strFileType = 14
    'Case Is = "dotm"
        'strFileType = 15
End Select

Start: 'Get Registry Data
On Error Resume Next 'No entry in registry will flag an error
strVer = oVars("varVersion").Value
On Error GoTo 0
If strVer = "" Then 'Variable does not exist
    strVer = "0"
    ActiveWorkbook.CustomDocumentProperties.Add Name:="varVersion", LinkToContent:=False, Type:=msoPropertyTypeString, Value:="0"
End If
strVer = Val(strVer) + 1 'Increment number
oVars("varVersion").Value = strVer
'Define the new version filename change version in line below to Rev if required
strVersionName = strPath & "\" & strFile & " - " & strDate & _
" - Rev " & Format(Val(strVer), "00# ") _
& Format(Time(), "hh-mm") & Chr(46) & sExt


   strNewPath = strPath & "\" & strNewFolderName & "\" & strFile & " - " & strDate & _
" - Rev " & Format(Val(strVer), "00# ") _
& Format(Time(), "hh-mm") & Chr(46) & sExt

'and save a copy of the file with that name
ActiveWorkbook.SaveAs strNewPath
ActiveWorkbook.SaveAs strVersionName

Kill strOldFilePath

Exit Sub

CancelledByUser: 'Error handler
MsgBox "Cancelled By User", , "Operation Cancelled"
End Sub

保存修订号日期时间宏

0 个答案: