如何使worksheet change事件规定区域中内用 批量复制粘贴多个单元格都能触发事件

zhenghui13

Application.Undo会批量进行操作，所以用两个临时数组记录内容，然后进行比较并记录。

1. 
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3. '    Const xRg As String = "A1:ZZ1000"
   
4.     Dim strOld As String
   
5.     Dim strNew As String
   
6.     Dim strCmt As String
   
7.     Dim xLen As Long
   
8.     Dim i, j
   
9.     Dim arr, brr
   
10.    
    
11.     Application.EnableEvents = False
    
12.     arr = UsedRange
    
13.     Application.Undo
    
14.     brr = UsedRange
    
15.    
    
16. '    Stop
    
17.     If Target.Count = 1 Then
    
18.     With Target
    
19.         i = Target.Row
    
20.         j = Target.Column
    
21.         If Target.Value = arr(i, j) Then Exit Sub
    
22.         strNew = arr(i, j)
    
23. '        Application.EnableEvents = False
    
24. '        Application.Undo
    
25.         strOld = brr(i, j)
    
26.         .Value = strNew
    
27. '        Application.EnableEvents = True
    
28.         strCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & _
    
29.         Application.UserName & Chr(10) & "Previous Text :- " & strOld
    
30.         If Target.Comment Is Nothing Then
    
31.             .AddComment
    
32.         Else
    
33.             xLen = Len(.Comment.Shape.TextFrame.Characters.Text)
    
34.         End If
    
35.         With .Comment.Shape.TextFrame
    
36.             .AutoSize = True
    
37.             .Characters(Start:=xLen + 1).Insert IIf(xLen, vbLf, "") & strCmt
    
38.         End With
    
39.     End With
    
40.     ElseIf Target.Count > 1 Then
    
41.         For Each Rng In Target
    
42.             With Rng
    
43.                 i = Rng.Row
    
44.                 j = Rng.Column
    
45.                 If Rng.Value = arr(i, j) Then Exit Sub
    
46.                 strNew = arr(i, j)
    
47. '                Application.EnableEvents = False
    
48. '                Application.Undo
    
49.                 strOld = brr(i, j)
    
50.                 .Value = strNew
    
51. '                Application.EnableEvents = True
    
52.                 strCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & _
    
53.                 Application.UserName & Chr(10) & "Previous Text :- " & strOld
    
54.                 If Rng.Comment Is Nothing Then
    
55.                     .AddComment
    
56.                 Else
    
57.                     xLen = Len(.Comment.Shape.TextFrame.Characters.Text)
    
58.                 End If
    
59.                 With .Comment.Shape.TextFrame
    
60.                     .AutoSize = True
    
61.                     .Characters(Start:=xLen + 1).Insert IIf(xLen, vbLf, "") & strCmt
    
62.                 End With
    
63.             End With
    
64.    
    
65.         Next
    
66.     End If
    
67. Application.EnableEvents = True
    
68. End Sub
    

复制代码

zhenghui13

附件仅供测试...

Yvonne-Zhang

zhenghui13 发表于 2018-8-22 16:00
附件仅供测试...

太厉害了。真的非常棒！！！感谢大神
但是测试的过程中我发现，如果粘贴的数据中有0（显示为-）或者空格，后面的数据就停止粘贴了，事件失效，再复制粘贴发现事件也无效了。在你的测试表格中也发现，如粘贴区域在17行下面会出现“下标越界”的弹窗。
在我的表格中靠下的行也是不能复制粘贴，单元格会跳空，之后事件失效。
与此同时，我的表格中其他工作表之前可以运行的事件和宏也都没有反应了，关闭表格之后重新打开又可以运行了。
请问是否事件作用的区域有限制呢，以上的情况可以避免嘛。
万分感谢，刚第一帖就有这么厉害的回复，感恩，研究一下怎么去送花花哈哈

zhenghui13

Yvonne-Zhang 发表于 2018-8-22 23:03
太厉害了。真的非常棒！！！感谢大神
但是测试的过程中我发现，如果粘贴的数据中有0（显示为-）或者空格 ...

请将以下两句注释掉试试.
If Target.Value = arr(i, j) Then Exit Sub
If Rng.Value = arr(i, j) Then Exit Sub

zxcvbnm0000000

zhenghui13 发表于 2018-8-22 13:51
没有附件不太好理解你在的效果。可否上传附件(ZIP)，然后做个效果。

麻烦大神看看
http://club.excelhome.net/thread-1472156-1-1.html
(出处: ExcelHome技术论坛)