请帮我把这个VBA代码改一下····

liurui0527

Sub 查找()
y = WorksheetFunction.Substitute([p2], "～", "至")
With Sheets("" & y).Range("A5:AU20")
A = [a65536].End(xlUp).Row
For r = 4 To A
m = Array(4, 5, 7, 8, 9, 11, 15)
For n = 0 To 6
c = m(n)
Set rng0 = .Find(what:=Cells(r, 1))
If Not rng0 Is Nothing Then
hang = rng0.Row
End If
Set rng1 = .Find(what:=Cells(3, c), lookat:=xlPart)
If Not rng1 Is Nothing Then
lie = rng1.Column
End If
'("D3:E3","G3:I3","K3","O3")的求和
If Cells(r, 1) <> "" Then Cells(r, c) = Worksheets("" & y).Cells(hang, lie)
Next
Next
End With
Call 另1
End Sub
Sub 另1()
y = WorksheetFunction.Substitute([p2], "～", "至")
With Sheets("" & y).Range("A5:AU20")
A = [a65536].End(xlUp).Row
For r = 4 To A
Set rng0 = .Find(what:=Cells(r, 1))
If Not rng0 Is Nothing Then
hang = rng0.Row
End If
'F4求和
t = Worksheets("" & y).Cells(hang, 45)
If t <> 0 Then
o = (Cells(r, 4) * 3) - ((Cells(r, 3) - t - Cells(r, 4)) * 8)
Else
o = (Cells(r, 4) * 3) - ((Cells(r, 3) - Cells(r, 4)) * 8)
End If
If Cells(r, 1) <> "" Then Cells(r, 6) = o
Next
End With
Call 另2
End Sub
Sub 另2()
y = WorksheetFunction.Substitute([p2], "～", "至")
With Sheets("" & y).Range("A5:AU20")
A = [a65536].End(xlUp).Row
For r = 4 To A
Set rng0 = .Find(what:=Cells(r, 1))
If Not rng0 Is Nothing Then
hang = rng0.Row
End If
'J列求和
If Cells(r, 1) <> "" Then Cells(r, 10) = Worksheets("" & y).Cells(hang, 41) * Cells(r, 5)
'L列求和
If Cells(r, 1) <> "" Then Cells(r, 12) = Worksheets("" & y).Cells(hang, 40) * 1.5 * Cells(r, 6)
'M列求和
If Cells(r, 1) <> "" Then Cells(r, 13) = Worksheets("" & y).Cells(hang, 40) * 11 * 2 * Cells(r, 7)
'N列求和
If Cells(r, 1) <> "" Then Cells(r, 14) = Worksheets("" & y).Cells(hang, 40) * 11 * 3 * Cells(r, 8)
Next
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$P$2" Then Call 查找
End Sub
这个红色里面的的结果不对（代码中为红色字体的几项），蓝色里的结果才对，由于小弟不会VBA所以找别人做了个表。出现的原因 Cells(r, 6)， * Cells(r, 7)， * Cells(r, 8)这几个要设置保留两位小数，并且要设置 一样的
莫某的（r, 6)， * Cells(r, 7)， * Cells(r, 8）他应该是按17.598算的，实际应该为17.6
李某的（r, 6)， * Cells(r, 7)， * Cells(r, 8）他应该是按22.569算的，实际应该为22.57
附件压缩后有1.5M所以传不上来，需要附件请留下邮件，或联系liurui168@live.com····

hehex

楼主你确认是红色这几句没有保留2位小数造成的计算错误的话：
下面红色语句调用工作表函数Round 对原来的语句计算结果进行保留2位小数的四舍五入。

If Cells(r, 1) <> "" Then Cells(r, 12) = WorksheetFunction.Round((Worksheets("" & y).Cells(hang, 40) * 1.5 * Cells(r, 6)),2)
'M&Aacute;&ETH;&Ccedil;ó&ordm;&Iacute;
If Cells(r, 1) <> "" Then Cells(r, 13) = WorksheetFunction.Round((Worksheets("" & y).Cells(hang, 40) * 11 * 2 * Cells(r, 7)),2)
'N&Aacute;&ETH;&Ccedil;ó&ordm;&Iacute;
If Cells(r, 1) <> "" Then Cells(r, 14) = WorksheetFunction.Round((Worksheets("" & y).Cells(hang, 40) * 11 * 3 * Cells(r, 8)),2)

liurui0527

hehex 发表于 2012-10-31 15:36
楼主你确认是红色这几句没有保留2位小数造成的计算错误的话：
下面红色语句调用工作表函数Round 对原来的语 ...

对的，你说的那个不能运行， ，写上去后运行出现上图····

hehex

简单：
'L列求和
If Cells(r, 1) <> "" Then
    Cells(r, 12) = Worksheets("" & y).Cells(hang, 40) * 1.5 * Cells(r, 6)
    Cells(r, 12).Value = WorksheetFunction.Round(Cells(r, 12).Value, 2)
End If
'M列求和
If Cells(r, 1) <> "" Then
    Cells(r, 13) = Worksheets("" & y).Cells(hang, 40) * 11 * 2 * Cells(r, 7)
    Cells(r, 13).Value = WorksheetFunction.Round(Cells(r, 13).Value, 2)
End If
'N列求和
If Cells(r, 1) <> "" Then
    Cells(r, 14) = Worksheets("" & y).Cells(hang, 40) * 11 * 3 * Cells(r, 8)
    Cells(r, 14).Value = WorksheetFunction.Round(Cells(r, 14).Value, 2)
End If
换成这样，应该是可以执行的

liurui0527

hehex 发表于 2012-10-31 16:27
简单：
'L列求和
If Cells(r, 1)  "" Then

还是不行，运行时出现 我把蓝色框里的删了会出现
不好意思啊，这里面可能有些常识性的问题，可我对这个一点都不懂，只有问你了

hehex

For 没有next 是你把循环都改了，可能是你更改的时候误把红色代码下面的那句Next 给删除了。
加回去就好了。
'L列求和
If Cells(r, 1) <> "" Then Cells(r, 12) = Worksheets("" & y).Cells(hang, 40) * 1.5 * Cells(r, 6)
'M列求和
If Cells(r, 1) <> "" Then Cells(r, 13) = Worksheets("" & y).Cells(hang, 40) * 11 * 2 * Cells(r, 7)
'N列求和
If Cells(r, 1) <> "" Then Cells(r, 14) = Worksheets("" & y).Cells(hang, 40) * 11 * 3 * Cells(r, 8)
是用我的语句把原来的这些代码替换掉，起到这些语句得出的结果四舍五入的效果，其他的保持原样不动。
还有上面的错误，end with 没有with 也和我给你替换的语句无关，是你误删了其他语句了。
我把你上面的代码复制下来，然后改了你说的红色代码，没动其他的，不行你再复制回去看看吧：

1. Sub 查找()
   
2.     y = WorksheetFunction.Substitute([p2], "～", "至")
   
3.     With Sheets("" & y).Range("A5:AU20")
   
4.         a = [a65536].End(xlUp).Row
   
5.         For r = 4 To a
   
6.             m = Array(4, 5, 7, 8, 9, 11, 15)
   
7.             For n = 0 To 6
   
8.                 c = m(n)
   
9.                 Set rng0 = .Find(what:=Cells(r, 1))
   
10.                 If Not rng0 Is Nothing Then
    
11.                     hang = rng0.Row
    
12.                 End If
    
13.                 Set rng1 = .Find(what:=Cells(3, c), lookat:=xlPart)
    
14.                 If Not rng1 Is Nothing Then
    
15.                     lie = rng1.Column
    
16.                 End If
    
17.                 '("D3:E3","G3:I3","K3","O3")的求和
    
18.                 If Cells(r, 1) <> "" Then Cells(r, c) = Worksheets("" & y).Cells(hang, lie)
    
19.             Next
    
20.         Next
    
21.     End With
    
22.     Call 另1
    
23. End Sub
    
24. Sub 另1()
    
25.     y = WorksheetFunction.Substitute([p2], "～", "至")
    
26.     With Sheets("" & y).Range("A5:AU20")
    
27.         a = [a65536].End(xlUp).Row
    
28.         For r = 4 To a
    
29.             Set rng0 = .Find(what:=Cells(r, 1))
    
30.             If Not rng0 Is Nothing Then
    
31.                 hang = rng0.Row
    
32.             End If
    
33.             'F4求和
    
34.             t = Worksheets("" & y).Cells(hang, 45)
    
35.             If t <> 0 Then
    
36.                 o = (Cells(r, 4) * 3) - ((Cells(r, 3) - t - Cells(r, 4)) * 8)
    
37.             Else
    
38.                 o = (Cells(r, 4) * 3) - ((Cells(r, 3) - Cells(r, 4)) * 8)
    
39.             End If
    
40.             If Cells(r, 1) <> "" Then Cells(r, 6) = o
    
41.         Next
    
42.     End With
    
43.     Call 另2
    
44. End Sub
    
45. Sub 另2()
    
46.     y = WorksheetFunction.Substitute([p2], "～", "至")
    
47.     With Sheets("" & y).Range("A5:AU20")
    
48.         a = [a65536].End(xlUp).Row
    
49.         For r = 4 To a
    
50.             Set rng0 = .Find(what:=Cells(r, 1))
    
51.             If Not rng0 Is Nothing Then
    
52.                 hang = rng0.Row
    
53.             End If
    
54.             'J列求和
    
55.             If Cells(r, 1) <> "" Then Cells(r, 10) = Worksheets("" & y).Cells(hang, 41) * Cells(r, 5)
    
56.             'L列求和
    
57.             If Cells(r, 1) <> "" Then
    
58.                 Cells(r, 12) = Worksheets("" & y).Cells(hang, 40) * 1.5 * Cells(r, 6)
    
59.                 Cells(r, 12).Value = WorksheetFunction.Round(Cells(r, 12).Value, 2)
    
60.             End If
    
61.             'M列求和
    
62.             If Cells(r, 1) <> "" Then
    
63.                 Cells(r, 13) = Worksheets("" & y).Cells(hang, 40) * 11 * 2 * Cells(r, 7)
    
64.                 Cells(r, 13).Value = WorksheetFunction.Round(Cells(r, 13).Value, 2)
    
65.             End If
    
66.             'N列求和
    
67.             If Cells(r, 1) <> "" Then
    
68.                 Cells(r, 14) = Worksheets("" & y).Cells(hang, 40) * 11 * 3 * Cells(r, 8)
    
69.                 Cells(r, 14).Value = WorksheetFunction.Round(Cells(r, 14).Value, 2)
    
70.             End If
    
71. 
    
72.         Next
    
73.     End With
    
74. End Sub
    
75. 
    

复制代码

liurui0527

你这个写上去，能正常运行了，但是结果还是没有变化····

hehex

给你发的邮件都被退回来了，不知道我的邮箱smtp server 是不是又罢工了。
我把代码贴在论坛上，你直接复制回去就能用了。和你蓝框里的数据是完全一致的。

1. 
   
2. Sub 查找()
   
3.     y = WorksheetFunction.Substitute([p2], "～", "至")
   
4.     With Sheets("" & y).Range("A5:AU20")
   
5.         A = [a65536].End(xlUp).Row
   
6.         For r = 4 To A
   
7.             m = Array(4, 5, 7, 8, 9, 11, 15)
   
8.             For n = 0 To 6
   
9.                 c = m(n)
   
10. 
    
11.                 Set rng0 = .Find(what:=Cells(r, 1))
    
12.                 If Not rng0 Is Nothing Then
    
13.                     hang = rng0.Row
    
14.                 End If
    
15. 
    
16.                 Set rng1 = .Find(what:=Cells(3, c), lookat:=xlPart)
    
17.                 If Not rng1 Is Nothing Then
    
18.                     lie = rng1.Column
    
19.                 End If
    
20. 
    
21.                 '("D3:E3","G3:I3","K3","O3")的求和
    
22.                 If Cells(r, 1) <> "" Then Cells(r, c) = Worksheets("" & y).Cells(hang, lie)
    
23.             Next
    
24.         Next
    
25.     End With
    
26.     Call 另1
    
27. End Sub
    
28. Sub 另1()
    
29.     y = WorksheetFunction.Substitute([p2], "～", "至")
    
30.     With Sheets("" & y).Range("A5:AU20")
    
31.         A = [a65536].End(xlUp).Row
    
32.         For r = 4 To A
    
33. 
    
34.             Set rng0 = .Find(what:=Cells(r, 1))
    
35.             If Not rng0 Is Nothing Then
    
36.                 hang = rng0.Row
    
37.             End If
    
38. 
    
39.             'F4求和
    
40.             t = Worksheets("" & y).Cells(hang, 45)
    
41.             If t <> 0 Then
    
42.                 o = (Cells(r, 4) * 3) - ((Cells(r, 3) - t - Cells(r, 4)) * 8)
    
43.             Else
    
44.                 o = (Cells(r, 4) * 3) - ((Cells(r, 3) - Cells(r, 4)) * 8)
    
45.             End If
    
46.             If Cells(r, 1) <> "" Then Cells(r, 6) = o
    
47.         Next
    
48.     End With
    
49.     Call 另2
    
50. End Sub
    
51. Sub 另2()
    
52.     y = WorksheetFunction.Substitute([p2], "～", "至")
    
53.     With Sheets("" & y).Range("A5:AU20")
    
54.         A = [a65536].End(xlUp).Row
    
55.         For r = 4 To A
    
56. 
    
57.             Set rng0 = .Find(what:=Cells(r, 1))
    
58.             If Not rng0 Is Nothing Then
    
59.                 hang = rng0.Row
    
60.             End If
    
61. 
    
62.             'J列求和
    
63.             If Cells(r, 1) <> "" Then Cells(r, 10) = Worksheets("" & y).Cells(hang, 41) * Cells(r, 5)
    
64.             'L列求和
    
65.             If Cells(r, 1) <> "" Then Cells(r, 12) = WorksheetFunction.Round(Worksheets("" & y).Cells(hang, 40).Value, 2) * 1.5 * Cells(r, 6).Value
    
66. 
    
67. '            'M列求和
    
68.             If Cells(r, 1) <> "" Then Cells(r, 13) = WorksheetFunction.Round(Worksheets("" & y).Cells(hang, 40).Value, 2) * 11 * 2 * Cells(r, 7).Value
    
69. 
    
70.             'N列求和
    
71.             If Cells(r, 1) <> "" Then Cells(r, 14) = WorksheetFunction.Round(Worksheets("" & y).Cells(hang, 40).Value, 2) * 11 * 3 * Cells(r, 8).Value
    
72. 
    
73.         Next
    
74.     End With
    
75. End Sub
    
76. 
    
77. 
    
78. Private Sub Worksheet_Change(ByVal Target As Range)
    
79.     If Target.Address = "$P$2" Then Call 查找
    
80. End Sub
    

复制代码