在取消共享时自动从共享的 Excel 工作簿中导出更改日志

Question

我的组织的网络共享驱动器上有一个共享工作簿，由几十个人编辑。大约每周一次，我需要将其从“共享”模式中取出（我们称之为“取消共享”），以便对这些编辑器输入的数据进行一些高级操作，并进行需要我取消保护工作表的更改/工作簿。另外，我偶尔需要对工作簿中的 VBA 代码进行维护，这也需要我取消共享工作簿。

问题在于，每次我取消共享时，它都会删除内部跟踪更改历史记录。我想自动将此历史记录导出到外部更改日志文件，否则每次保存更改历史记录都需要繁琐且耗时的手动操作。

Answer 1

在互联网上四处寻找访问 Excel 内部更改历史记录的方法但一无所获后，我选择了这个解决方案，该解决方案利用 Excel 的突出显示更改选项临时创建一个“历史记录”表，然后附加列出的更改在那张纸上到一个 csv 文件。我还尝试使其相对可重用和模块化：

'My function that disables workbook sharing
Function UnshareWkbk(wkbk as Workbook) as Boolean
    on Error goto errUnshare
    'If Sharing is already disabled, return TRUE and exit
    If Not (wkbk.MultiUserEditing) Then
        UnshareWkbk = True
        Exit Function
    Else
        'Sharing is enabled, unshare the workbook here
        Application.DisplayAlerts = False

        'If we are about to Unshare, we need to export the change log first
        Call ExportChangeLog(ThisWorkbook, "1/1/1900")

        'Go ahead and Unshare the workbook, it's safe to erase the change history
        wkbk.ExclusiveAccess
        Application.DisplayAlerts = True
    End If

    'Make sure it worked and return TRUE
    If Not (ThisWorkbook.MultiUserEditing) Then UnshareWkbk = True
    Exit Function

errUnshare:
    '[add your own error handling here as applicable]
    Application.DisplayAlerts = True
End Function

'Export changes from workbook from selected date to present
Sub ExportChangeLog(wkbk As Workbook, fromDate As Date)
    Dim rng As Range, rw As Range
    Dim logFile As Integer, logPath As String
    Dim isNewFile As Boolean, fileIsOpen As Boolean
    Dim errStr As String

    On Error GoTo changeLogErr

    With wkbk
        'If the workbook is open in read only mode then we don't need to save
        'the changelog since the change history won't be erased
        If wkbk.ReadOnly Then GoTo endExportLog

        'Create History sheet for changelog using Excel's Hightlight Changes procedure
        .HighlightChangesOptions When:=Format(fromDate, "m/d/yyyy")
        .ListChangesOnNewSheet = True
        .HighlightChangesOnScreen = False

        'If a History sheet is not created that means there have been no changes since 
        'the chosen date, so go ahead and skip this procedure.
        On Error GoTo endExportLog

        With .Sheets("History")
            On Error GoTo changeLogErr
            .Activate

            'Set rng to just the actual changes in the change log, ignoring the extra data
            'output by Excel in the History worksheet and the headers
            'Note: you may care about this additional data, I do not
            On Error Resume Next
            Set rng = .UsedRange.Resize(.UsedRange.Rows.Count - 3).Offset(1)
            Set rng = rng.Resize(rng.Rows.Count, rng.Columns.Count - 3).Offset(0, 1)
            On Error GoTo changeLogErr

            'If no rng is set, the History sheet was created but there were no
            'changes... this shouldn't happen, but just in case I've added this
            'code which will skip this procedure
            If rng Is Nothing Then GoTo endExportLog
        End With

        'Move view away from the History sheet
        .Sheets(1).Activate
    End With

    'Initialize the log file
    logPath = wkbk.Path & "\changelog.csv"
    logFile = FreeFile  'Next available file number

    'If the file doesn't currently exist, set isNewFile to TRUE
    isNewFile = Dir(logPath) = ""

    Open logPath For Append As logFile

    'If we've made it here then the log file is ready to be written to
    fileIsOpen = True

    'Print table headers if the file doesn't yet exist
    If isNewFile Then
        'If you changed the rng selection above, you may need to update the 
        'table headers here:
        Print #logFile, "DATE,TIME,WHO,CHANGE,SHEET,RANGE,NEW VALUE,OLD VALUE"
    End If

    'For each row in the change log, write to the CSV
    For Each rw In rng.Rows
        Print #logFile, RangeToCSV(rw)
    Next rw

    'UNTESTED, but you should be able to replace the above for loop with this*
    'Print #logFile, RangeToCSV(rng)

endExportLog:
    On Error Resume Next
    'Save and close changelog
    If fileIsOpen Then Close #logFile
    Set rng = Nothing: Set rw = Nothing
    Exit Sub

changeLogErr:
    errStr = "ERROR #" & Err.Number & " - " & Err.Description
    msgbox errStr
    On Error Resume Next
    'If an error happened after preparing the log file, we can also log the error there
    if fileIsOpen then Print #logFile, "ERROR," & Format(Now(), "YYYY.MM.DD_hhmm") & "," & errStr
    Resume endExportLog
End Sub

'Convert a given range (1D or 2D) to CSV and return as a string
Function RangeToCSV(ByRef rng As Range) As String
    Dim arr() As Variant, strArr() As String
    Dim outputStr As String, i As Long, j As Long

    'If only one cell in rng, return just that cell's value
    If rng.Cells.Count = 1 Then
        RangeToCSV = rng.Value2
        GoTo endRngToCSV
    End If

    'Store values of range to array
    arr() = rng.Value2
    ReDim strArr(0 To UBound(arr, 2) - 1)

    'More than 1 row of data, add vbnewline between csv rows
    If rng.Rows.Count > 1 Then
        For j = LBound(arr, 1) To UBound(arr, 1)
            For i = LBound(arr, 2) To UBound(arr, 2)
                strArr(i - 1) = Replace(arr(j, i), ",", ".")
            Next i
            outputStr = IIf(j = 1, Join(strArr, ","), outputStr & vbNewLine & Join(strArr, ","))
        Next j
    Else 
        'Only one row of csv data
        For i = LBound(arr, 2) To UBound(arr, 2)
            strArr(i - 1) = Replace(arr(1, i), ",", ".")
        Next i
        outputStr = Join(strArr, ",")
    End If

    'Return CSV output
    RangeToCSV = outputStr

endRngToCSV:
    'Clean up
    On Error Resume Next
    Erase arr: Erase strArr: Set rng = Nothing: outputStr = ""
End Function

*我最初编写的 RangeToCSV 函数只适用于单行数据，因此 ExportChangeLog 过程中的 for each rw 循环