VBA应用——记录更改履历

阁主在工作过程中，用excel编制一些文件，需要记录变更履历。而excel没有一个方便的版本管理工具，阁主就想到了excel自带的vba环境。何不自己写一个出来呢？

先来说说编程思路，思路对了，程序就出来了一半。

首先，我们记录更改履历，就需要记录原值，而excel工作簿和工作表的change事件不能返回原值，所以阁主采用了一个取巧的办法，当然，在使用时候就有了限制。

软件思路

①更改发生，产生change事件，并伴随参数target和sh，target是变更的区域，sh是变更的工作表。

②worksheet的change事件代码运行。这时，可以获取到更改区域和更改后的值，将更改后的值存放到数组中以备用。

③调用application.undo方法。该方法放弃修改后的新值并返回原值。将原值存入数组。

④再次调用application.undo方法。恢复目标区域的值为修改后的值。

⑤将获取到的值写入变更履历工作表中

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    Dim TimeFormatString As String
    Dim TimeStamp As String
    Const VersionControlSheetName = "版本控制"
    '版本控制页名称有更改的，请变更此常量
    
    TimeFormatString = "yyyy-mmm-dd HH:mm:ss"
    '时间戳文本格式
    
    Dim AvailableZone As String
    AvailableZone = "A1:Q42"
    '有效区域地址
    
    If Application.Union(Target, Range(AvailableZone)).Address = Range(AvailableZone).Address Then
         TimeStamp = Format(Now, TimeFormatString)
         '
         '
         
         Dim enableEventsFlag As Boolean
         enableEventsFlag = Application.EnableEvents
         Application.EnableEvents = False
         '防止循环调用
         
         If Target.Areas.Count > 1 Then
             '多重区域无效
             MsgBox ("只能选择单一区域进行更改")
             Application.Undo
        ' ElseIf Target.MergeCells Then
        '     MsgBox "不能用于合并单元格!"
        '     Application.Undo
         ElseIf Sh.Name <> VersionControlSheetName Then
             Dim newValue(), oldVaue(), rNum, cNum, rNums, cNums
             Dim actcel As Range
             Set actcel = ActiveCell
             rNums = Target.Rows.Count
             cNums = Target.Columns.Count
             '获取目标区域大小
             
             ReDim newValue(1 To rNums, 1 To cNums)
             
             For rNum = 1 To rNums
                 For cNum = 1 To cNums
                     newValue(rNum, cNum) = Target.Cells(rNum, cNum).Formula
                 Next
             Next
             '获取目标修改后区域值
             
             Application.Undo
             
             ReDim oldvalue(1 To rNums, 1 To cNums)
             
             For rNum = 1 To rNums
                 For cNum = 1 To cNums
                     oldvalue(rNum, cNum) = Target.Cells(rNum, cNum).Formula
                 Next
             Next
             '获取目标修改前区域值
             
             Application.Undo
             Dim arr(), m
             m = 0
             For rNum = 1 To rNums
                 For cNum = 1 To cNums
                     If (oldvalue(rNum, cNum) <> "" Or newValue(rNum, cNum) <> "") And (oldvalue(rNum, cNum) <> newValue(rNum, cNum)) Then
                         m = m + 1
                         ReDim Preserve arr(1 To 5, 1 To m)
                         arr(1, m) = TimeStamp
                         '时间戳
                         arr(2, m) = "=hyperlink(""#" & Sh.Name & "!" & Target.Cells(rNum, cNum).Address & """,""" & Sh.Name & "!" & Target.Cells(rNum, cNum).Address & """)"
                         '变更位置链接链接
                         arr(3, m) = oldvalue(rNum, cNum)
                         '变更前值
                         arr(4, m) = newValue(rNum, cNum)
                         '变更后值
                     End If
                 Next
             Next
             Dim arr2
             If m > 0 Then
                 arr2 = Application.WorksheetFunction.Transpose(arr)
                 Sheets(VersionControlSheetName).Range("A65535").End(xlUp).Resize(UBound(arr, 2), UBound(arr)).Offset(1, 0) = arr2
             End If
             '处理并输出版本控制内容
             
             actcel.Activate
             
         End If
             
         Application.EnableEvents = enableEventsFlag
    End If
End Sub

更改履历能够处理的是使用者的键入、删除、更改操作，对于执行vba或者其他方面造成的更改无法记录。这是源于阁主使用了application.undo方法来获取更改位置的原值。而vba等操作过的数据，该方法不适用。