在取消共享时，自动从共享的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循环。