[已解决]Worksheet_SelectionChange求优化代码

xxjjdd0000

当

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Dim x%, y&, z&, br, ran$, ar
   
3. ran = Target.Range("d6:d10", "e6:e10").Column
   
4. br = Sheet2.Range("a65536").End(xlUp).Row
   
5. With Sheet2
   
6. For x = 6 To 10
   
7. For y = 3 To br
   
8. ar = .Cells(y, 256).End(3).Column
   
9. For z = 19 To ar Step 8
   
10. If Cells(x, 4) = .Cells(y, 4) Then
    
11. Cells(x, 2) = .Cells(y, 5)
    
12. Cells(x, 3) = .Cells(y, 6)
    
13. Cells(x, 8) = .Cells(y, 9)
    
14. Cells(x, 9) = .Cells(y, 10)
    
15. Cells(x, 10) = .Cells(y, 11)
    
16. End If
    
17. If Cells(x, 4) = .Cells(y, 4) And .Cells(y, z) <> "" Then
    
18. Cells(x, 5) = .Cells(y, z)
    
19. End If
    
20. Next z
    
21. If Cells(x, 4) = .Cells(y, 4) And .Cells(y, 15) = "" Then
    
22. Cells(x, 5) = .Cells(y, 7)
    
23. 
    
24. End If
    
25. Next y
    
26. If Range("F" & x) > 0 Then
    
27. Range("G" & x) = Range("F" & x) / 20
    
28. End If
    
29. Next x
    
30. End With
    
31. End Sub
    

复制代码

Target.zip (17.11 KB, 下载次数: 6)

2013-2-26 17:07 上传

点击文件名下载附件

我输入SHEET1黄色部分内容时，自动引用SHEET2的部分内容，本人菜鸟，速度太慢了，求优化代码。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-2-26 19:54

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. 
   
3.     Dim rg As Range
   
4.     Dim arr(1 To 9)
   
5.     Dim arrPos, i
   
6.     arrPos = Array(5, 6, 4, 7, 1, 8, 9, 10, 11)
   
7.     If Target.Count > 1 Then Exit Sub
   
8.     If Len(Target.Value) = 0 Then Exit Sub
   
9. 
   
10.     Select Case Target.Column
    
11.         
    
12.         Case 4
    
13.             '处理第4列
    
14.             With Sheet2
    
15.                 Set rg = .Columns("d").Find(what:=Target.Value, lookat:=xlWhole)
    
16.                 If rg Is Nothing Then
    
17.                     '清空当前行内容
    
18.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
19.                     Exit Sub
    
20.                 End If
    
21.                 Application.EnableEvents = False
    
22.                 irow = rg.Row
    
23.                 For i = LBound(arrPos) To UBound(arrPos)
    
24.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
25.                 Next
    
26.             End With
    
27.             '保留当前行的5,6列内容
    
28.             arr(5) = Cells(Target.Row, "f")
    
29.             arr(6) = Cells(Target.Row, "g")
    
30.             Cells(Target.Row, "b").Resize(, 9) = arr
    
31. 
    
32.         Case 6
    
33.             '处理第6列
    
34.             With Sheet2
    
35.                 Set rg = .Columns("d").Find(what:=Target.Offset(, -2).Value, lookat:=xlWhole)
    
36.                 If rg Is Nothing Then
    
37.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
38.                     Exit Sub
    
39.                 End If
    
40.                 Application.EnableEvents = False
    
41.                 irow = rg.Row
    
42.                 For i = LBound(arrPos) To UBound(arrPos)
    
43.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
44.                 Next
    
45.             End With
    
46.             arr(5) = Cells(Target.Row, "f")
    
47.             arr(6) = Cells(Target.Row, "g")
    
48.             Application.EnableEvents = False
    
49.             Cells(Target.Row, "b").Resize(, 9) = arr
    
50.         Case Else
    
51.             Exit Sub
    
52.     End Select
    
53.     Application.EnableEvents = True
    
54. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

出库件数500是怎么来的。表里没看出来。

xxjjdd0000

hwc2ycy 发表于 2013-2-26 17:29
出库件数500是怎么来的。表里没看出来。

是需要出库的件数，需要多少，输入多少，不能大于总库存。

hwc2ycy

是当在D列输入车号时，其他列的数据自动显示出来，F列输入的内容必需小于库存数，否则就清空F列么？

xxjjdd0000

hwc2ycy 发表于 2013-2-26 17:47
是当在D列输入车号时，其他列的数据自动显示出来，F列输入的内容必需小于库存数，否则就清空F列么？

也可以清空，也可以不清空，因为在E列看得见总库存数，不会把出库数大于总库存数。

hwc2ycy

你这吨位列也是错的啊。

无聊的疯子

选择事件不建议这样使用,最好限制一下选择的范围,不然,随便选择一个单元格都要计算一下,

要是公司的电脑累死了还没事,自己的电脑累死了就亏大了!!

xxjjdd0000

hwc2ycy 发表于 2013-2-26 19:30
你这吨位列也是错的啊。

没有错啊， If Range("F" & x) > 0 Then                    Range("G" & x) = Range("F" & x) / 20每件重量50KG，1吨就是20件，除下来就是吨位了

hwc2ycy

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. 
   
3.     Dim rg As Range
   
4.     Dim arr(1 To 9)
   
5.     Dim arrPos, i
   
6.     arrPos = Array(5, 6, 4, 7, 1, 8, 9, 10, 11)
   
7.     If Target.Count > 1 Then Exit Sub
   
8.     If Len(Target.Value) = 0 Then Exit Sub
   
9. 
   
10.     Select Case Target.Column
    
11.         
    
12.         Case 4
    
13.             '处理第4列
    
14.             With Sheet2
    
15.                 Set rg = .Columns("d").Find(what:=Target.Value, lookat:=xlWhole)
    
16.                 If rg Is Nothing Then
    
17.                     '清空当前行内容
    
18.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
19.                     Exit Sub
    
20.                 End If
    
21.                 Application.EnableEvents = False
    
22.                 irow = rg.Row
    
23.                 For i = LBound(arrPos) To UBound(arrPos)
    
24.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
25.                 Next
    
26.             End With
    
27.             '保留当前行的5,6列内容
    
28.             arr(5) = Cells(Target.Row, "f")
    
29.             arr(6) = Cells(Target.Row, "g")
    
30.             Cells(Target.Row, "b").Resize(, 9) = arr
    
31. 
    
32.         Case 6
    
33.             '处理第6列
    
34.             With Sheet2
    
35.                 Set rg = .Columns("d").Find(what:=Target.Offset(, -2).Value, lookat:=xlWhole)
    
36.                 If rg Is Nothing Then
    
37.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
38.                     Exit Sub
    
39.                 End If
    
40.                 Application.EnableEvents = False
    
41.                 irow = rg.Row
    
42.                 For i = LBound(arrPos) To UBound(arrPos)
    
43.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
44.                 Next
    
45.             End With
    
46.             arr(5) = Cells(Target.Row, "f")
    
47.             arr(6) = Cells(Target.Row, "g")
    
48.             Application.EnableEvents = False
    
49.             Cells(Target.Row, "b").Resize(, 9) = arr
    
50.         Case Else
    
51.             Exit Sub
    
52.     End Select
    
53.     Application.EnableEvents = True
    
54. End Sub

复制代码

hwc2ycy

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim rg As Range
   
3.     Dim arr(1 To 9)
   
4.     Dim arrPos, i As Byte
   
5.     arrPos = Array(5, 6, 4, 7, 1, 8, 9, 10, 11)
   
6.     If Target.Count > 1 Then Exit Sub
   
7.     If Len(Target.Value) = 0 Then Exit Sub
   
8. 
   
9.     Select Case Target.Column
   
10.         
    
11.         Case 4
    
12.             '处理第4列
    
13.             With Sheet2
    
14.                 Set rg = .Columns("d").Find(what:=Target.Value, lookat:=xlWhole)
    
15.                 If rg Is Nothing Then
    
16.                     '清空当前行内容
    
17.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
18.                     Exit Sub
    
19.                 End If
    
20.                 irow = rg.Row
    
21.                 For i = LBound(arrPos) To UBound(arrPos)
    
22.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
23.                 Next
    
24.             End With
    
25.             '保留当前行的5,6列内容
    
26.             arr(5) = Cells(Target.Row, "f")
    
27.             arr(6) = Cells(Target.Row, "g")
    
28.             Cells(Target.Row, "b").Resize(, 9) = arr
    
29. 
    
30.         Case 6
    
31.             '处理第6列
    
32.             With Sheet2
    
33.                 Set rg = .Columns("d").Find(what:=Target.Offset(, -2).Value, lookat:=xlWhole)
    
34.                 If rg Is Nothing Then
    
35.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
36.                     Exit Sub
    
37.                 End If
    
38.                 irow = rg.Row
    
39.                 For i = LBound(arrPos) To UBound(arrPos)
    
40.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
41.                 Next
    
42.             End With
    
43.             arr(5) = Cells(Target.Row, "f")
    
44.             arr(6) = Cells(Target.Row, "g")
    
45.             Cells(Target.Row, "b").Resize(, 9) = arr
    
46.         Case Else
    
47.             Exit Sub
    
48.     End Select
    
49. End Sub
    
50. 
    
51. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
52. 
    
53.     Dim rg As Range
    
54.     Dim arr(1 To 9)
    
55.     Dim arrPos, i As Byte
    
56.     arrPos = Array(5, 6, 4, 7, 1, 8, 9, 10, 11)
    
57.     If Target.Count > 1 Then Exit Sub
    
58.     If Len(Target.Value) = 0 Then Exit Sub
    
59. 
    
60.     Select Case Target.Column
    
61.         
    
62.         Case 4
    
63.             '处理第4列
    
64.             With Sheet2
    
65.                 Set rg = .Columns("d").Find(what:=Target.Value, lookat:=xlWhole)
    
66.                 If rg Is Nothing Then
    
67.                     '清空当前行内容
    
68.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
69.                     Exit Sub
    
70.                 End If
    
71.                 'Application.EnableEvents = False
    
72.                 irow = rg.Row
    
73.                 For i = LBound(arrPos) To UBound(arrPos)
    
74.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
75.                 Next
    
76.             End With
    
77.             '保留当前行的5,6列内容
    
78.             arr(5) = Cells(Target.Row, "f")
    
79.             arr(6) = Cells(Target.Row, "g")
    
80.             Cells(Target.Row, "b").Resize(, 9) = arr
    
81. 
    
82.         Case 6
    
83.             '处理第6列
    
84.             With Sheet2
    
85.                 Set rg = .Columns("d").Find(what:=Target.Offset(, -2).Value, lookat:=xlWhole)
    
86.                 If rg Is Nothing Then
    
87.                     Cells(Target.Row, "b").Resize(, 9) = arr
    
88.                     Exit Sub
    
89.                 End If
    
90.                 irow = rg.Row
    
91.                 For i = LBound(arrPos) To UBound(arrPos)
    
92.                     arr(i + 1) = .Cells(irow, arrPos(i))
    
93.                 Next
    
94.             End With
    
95.             arr(5) = Cells(Target.Row, "f")
    
96.             arr(6) = Cells(Target.Row, "g")
    
97.             Cells(Target.Row, "b").Resize(, 9) = arr
    
98.         Case Else
    
99.             Exit Sub
    
100.     End Select
     
101. End Sub
     

复制代码

其实监视 Change事件是否更好了。