如何在Excel中记住或保存已更改单元格的先前单元格值？

Dim xRg As Range Dim xChangeRg As Range Dim xDependRg As Range Dim xDic As New Dictionary Private Sub Worksheet_Change(ByVal Target As Range) Dim I As Long Dim xCell As Range Dim xDCell As Range Dim xHeader As String Dim xCommText As String On Error Resume Next Application.ScreenUpdating = False Application.EnableEvents = False xHeader = "Previous value :" x = xDic.Keys For I = 0 To UBound(xDic.Keys) Set xCell = Range(xDic.Keys(I)) Set xDCell = Cells(xCell.Row, 7) xDCell.Value = "" xDCell.Value = xDic.Items(I) Next Application.EnableEvents = True Application.ScreenUpdating = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim I, J As Long Dim xRgArea As Range On Error GoTo Label1 If Target.Count > 1 Then Exit Sub Application.EnableEvents = False Set xDependRg = Target.Dependents If xDependRg Is Nothing Then GoTo Label1 If Not xDependRg Is Nothing Then Set xDependRg = Intersect(xDependRg, Range("C:C")) End If Label1: Set xRg = Intersect(Target, Range("C:C")) If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then Set xChangeRg = Union(xRg, xDependRg) ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then Set xChangeRg = xDependRg ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then Set xChangeRg = xRg Else Application.EnableEvents = True Exit Sub End If xDic.RemoveAll For I = 1 To xChangeRg.Areas.Count Set xRgArea = xChangeRg.Areas(I) For J = 1 To xRgArea.Count xDic.Add xRgArea(J).Address, xRgArea(J).Formula Next Next Set xChangeRg = Nothing Set xRg = Nothing Set xDependRg = Nothing Application.EnableEvents = True End Sub

Dim xRg As Range Dim xChangeRg As Range Dim xDependRg As Range Dim xDic As New Dictionary Private Sub Worksheet_Change(ByVal Target As Range) Dim I As Long Dim xCell As Range Dim xHeader As String Dim xCommText As String On Error Resume Next Application.ScreenUpdating = False Application.EnableEvents = False xHeader = "Previous value :" For I = 0 To UBound(xDic.Keys) Set xCell = Range(xDic.Keys(I)) If Not xCell.Comment Is Nothing Then xCell.Comment.Delete With xCell .AddComment .Comment.Visible = False .Comment.Text xHeader & vbCrLf & xDic.Items(I) End With Next Application.EnableEvents = True Application.ScreenUpdating = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim I, J As Long Dim xRgArea As Range On Error GoTo Label1 If Target.Count > 1 Then Exit Sub Application.EnableEvents = False Set xDependRg = Target.Dependents If xDependRg Is Nothing Then GoTo Label1 If Not xDependRg Is Nothing Then Set xDependRg = Intersect(xDependRg, Range("C:C")) End If Label1: Set xRg = Intersect(Target, Range("C:C")) If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then Set xChangeRg = Union(xRg, xDependRg) ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then Set xChangeRg = xDependRg ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then Set xChangeRg = xRg Else Application.EnableEvents = True Exit Sub End If xDic.RemoveAll For I = 1 To xChangeRg.Areas.Count Set xRgArea = xChangeRg.Areas(I) For J = 1 To xRgArea.Count xDic.Add xRgArea(J).Address, xRgArea(J).Text Next Next Set xChangeRg = Nothing Set xRg = Nothing Set xDependRg = Nothing Application.EnableEvents = True End Sub

最佳办公生产力工具

在Word，Excel，PowerPoint中启用选项卡式编辑和阅读，发布者，Access，Visio和Project。 在同一窗口的新选项卡中而不是在新窗口中打开并创建多个文档。 每天将您的工作效率提高50％，并减少数百次鼠标单击！