После того, как вы попытались найти способ доступа к внутренней истории изменений Excel и ничего не нашли, я остановился на этом решении, которое использует параметр Excel Highlight Changes для временного создания листа «История», а затем добавления изменения, перечисленные на этом листе, в файл 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 для работы только с отдельными строками данных, поэтому для каждого rw l oop в процедуре ExportChangeLog