我在组织的网络共享驱动器上有一个共享工作簿，该工作簿由几十个人编辑。大约每周一次，我需要将其从"共享"模式(我们称之为"取消共享"(中取出，对这些编辑器输入的数据运行一些高级操作，并进行需要我取消保护工作表/工作簿的更改。此外，我偶尔需要对工作簿中的 VBA 代码执行维护，这也要求我取消共享工作簿。
问题是，每次我取消共享时，它都会删除内部轨道更改历史记录。我想自动将此历史记录导出到外部更改日志文件，否则每次保存更改历史记录都需要繁琐且耗时的手动工作。
在互联网上四处寻找一种访问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 过程中的每个 rw 循环