求助VBA代码

秦蜀新

非常感谢老师。

秦蜀新

老师非常感谢你帮我解决了溢出问题，但还存在一个问题：当从工作簿2往工作簿1里复制两条及以上数字时，出现运行时错误“94”无效使用Null，请有时间了帮忙解决一下。谢谢！

humanmagic

1.   Private Sub Worksheet_Change(ByVal Target As Range)
   
2.       
   
3.         Dim rngs As Range, rng As Range
   
4.         Set rngs = Range("B3:J1000") '这里改你要监视的区域
   
5.         If Intersect(rngs, Target) Is Nothing Then Exit Sub
   
6.         Dim arr
   
7.         arr = rngs.Value
   
8.         Dim x As Long, y As Long, str As String
   
9.         For Each rng In Intersect(rngs, Target)
   
10.             x = rng.Row - rngs.Row + 1
    
11.             y = rng.Column - rngs.Column + 1
    
12.             str = rng.Text
    
13.             Dim i As Long, j As Long
    
14.             For i = LBound(arr) To UBound(arr)
    
15.                 For j = LBound(arr, 2) To UBound(arr, 2)
    
16.                     If i <> x Or j <> y Then
    
17.                         If arr(i, j) = str Then
    
18.                             Application.EnableEvents = False
    
19.                             arr(i, j) = Empty
    
20.                             Application.EnableEvents = True
    
21.                         End If
    
22.                     End If
    
23.                 Next j
    
24.             Next i
    
25.         Next rng
    
26.         Application.EnableEvents = False
    
27.         rngs.Value = arr
    
28.         Application.EnableEvents = True
    
29.       
    
30. End Sub

复制代码

秦蜀新

老师，非常感谢你，麻烦你多次，还有一个问题：即当从工作簿2复制有重复的数据到工作簿1里时，在工作簿中把重复数据都清除了，正确的是保留唯一值（重复数据保留一个），谢谢！

humanmagic

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.       
   
3.     Dim rngs As Range, rng As Range
   
4.     Set rngs = Range("B3:J1000") '这里改你要监视的区域
   
5.     If Intersect(rngs, Target) Is Nothing Then Exit Sub
   
6.     Dim arr
   
7.     arr = rngs.Value
   
8.     Dim x As Long, y As Long, str As String
   
9.     For Each rng In Intersect(rngs, Target)
   
10.         If IsEmpty(rng) Then GoTo 100
    
11.         x = rng.Row - rngs.Row + 1
    
12.         y = rng.Column - rngs.Column + 1
    
13.         arr(x, y) = rng.Value
    
14.         str = rng.text
    
15.         Dim i As Long, j As Long
    
16.         For i = LBound(arr) To UBound(arr)
    
17.             For j = LBound(arr, 2) To UBound(arr, 2)
    
18.                 If i <> x Or j <> y Then
    
19.                     If arr(i, j) = str Then
    
20.                         Application.EnableEvents = False
    
21.                         arr(i, j) = Empty
    
22.                         Application.EnableEvents = True
    
23.                     End If
    
24.                 End If
    
25.             Next j
    
26.         Next i
    
27. 100:
    
28.     Next rng
    
29.     Application.EnableEvents = False
    
30.     rngs.Value = arr
    
31.     Application.EnableEvents = True
    
32.       
    
33. End Sub

复制代码

秦蜀新

问题解决了，非常感谢！

秦蜀新

老师，想再麻烦你，请你在上次你给我写代码的附件上增加一个功能，即当输入原来存在的数据后，在清除原来数据的同时（这个目的你已经帮我达到了），被清除数据的下方单元格数据能自动上移（也就是数据之间不留空单元格。但不能用删除单元格上移的方法，见附件）。谢谢！

humanmagic

秦蜀新 发表于 2018-8-23 10:46
老师，想再麻烦你，请你在上次你给我写代码的附件上增加一个功能，即当输入原来存在的数据后，在清除原来数 ...

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.       
   
3.     Dim rngs As Range, rng As Range, valRng As Range
   
4.     Set rngs = Range("B3:J1000000") '这里改你要监视的区域
   
5.     If Intersect(rngs, Target) Is Nothing Then Exit Sub
   
6.     Set valRng = Union(ActiveSheet.UsedRange, Intersect(rngs, Target))
   
7.     Dim arr
   
8.     arr = valRng.Value
   
9.     Dim x As Long, y As Long, str As String
   
10.     For Each rng In Intersect(rngs, Target)
    
11.         If IsEmpty(rng) Then GoTo continue
    
12.         x = rng.Row - valRng.Row + 1
    
13.         y = rng.Column - valRng.Column + 1
    
14.         arr(x, y) = rng.Value
    
15.         str = rng.Text
    
16.         Dim i As Long, j As Long
    
17.         For i = LBound(arr) To UBound(arr)
    
18.             For j = LBound(arr, 2) To UBound(arr, 2)
    
19.                 If i <> x Or j <> y Then
    
20.                     If arr(i, j) = str Then
    
21.                         arr(i, j) = Empty
    
22.                     End If
    
23.                 End If
    
24.             Next j
    
25.         Next i
    
26. continue:
    
27.     Next rng
    
28.     Set rng = Nothing
    
29.     For i = LBound(arr) To UBound(arr)
    
30.         For j = LBound(arr, 2) To UBound(arr, 2)
    
31.             If IsEmpty(arr(i, j)) Then
    
32.                 x = i
    
33.                 For y = i + 1 To UBound(arr)
    
34.                     If Not IsEmpty(arr(y, j)) Then
    
35.                         arr(x, j) = arr(y, j)
    
36.                         arr(y, j) = Empty
    
37.                         x = x + 1
    
38.                     End If
    
39.                 Next y
    
40.             End If
    
41.         Next j
    
42.     Next i
    
43.     Application.EnableEvents = False
    
44.     valRng.Value = arr
    
45.     Application.EnableEvents = True
    
46.     Erase arr
    
47.     Set valRng = Nothing
    
48.     Set rngs = Nothing
    
49.       
    
50. End Sub

复制代码

秦蜀新

老师，你写的代码非常好，但还存在一个问题：即当在空单元格输入原来有的数据，回车后把上面的计算公式清除了，看能否解决，如果麻烦就算了，我可以在另外的工作簿中进行计算。谢谢！

秦蜀新

老师，你好！当在附件中输入原来有的数字时，在清除原来有的数字后，第一行的公式不计算了，麻烦你抽时间看一下。谢谢！