[已解决]能不能修改下代码？

dadasdas

帮忙精简下代码？
Sub test()
    For i = 5 To Range("H" & Rows.Count).End(3).Row
        If Cells(i, 8).Interior.ColorIndex = 40 And Cells(i, 8) <> "" Then
            Cells(i, 30) = Cells(i, 8).Value
            Cells(i, 31) = 10: Cells(i, 21) = "1": Cells(i, 23) = "2": Cells(i, 26) = "d"
            Cells(i, 32) = Cells(i, 31) * Cells(i, 30)
        ElseIf Cells(i, 8).Interior.ColorIndex = 44 And Cells(i, 8) <> "" Then
            Cells(i, 30) = Cells(i, 8).Value
            Cells(i, 31) = 50: Cells(i, 21) = "1": Cells(i, 23) = "2": Cells(i, 26) = "b"
            Cells(i, 32) = Cells(i, 31) * Cells(i, 30)
        ElseIf Cells(i, 8).Interior.ColorIndex = 45 And Cells(i, 8) <> "" Then
            Cells(i, 30) = Cells(i, 8).Value
            Cells(i, 31) = 60: Cells(i, 21) = "1": Cells(i, 23) = "2": Cells(i, 26) = "c"
            Cells(i, 32) = Cells(i, 31) * Cells(i, 30)
        ElseIf Cells(i, 8).Interior.ColorIndex = 46 And Cells(i, 8) <> "" Then
            Cells(i, 30) = Cells(i, 8).Value
            Cells(i, 31) = 70: Cells(i, 21) = "1": Cells(i, 23) = "2": Cells(i, 26) = "a"
            Cells(i, 32) = Cells(i, 31) * Cells(i, 30)
        End If
    Next
End Sub

最佳答案

月排行榜 / 总排行榜

爱疯

2013-2-17 17:32

Book1d.rar (15.47 KB, 下载次数: 18)

2013-2-17 17:29 上传

点击文件名下载附件

这样可以吗

跳转到最佳答案楼层

无聊的疯子

没有附件,只有这样修改,只能提升一点速度!!

1. 
   
2. Sub test()
   
3. Dim Ys As Byte
   
4.     For i = 5 To Range("H" & Rows.Count).End(3).Row
   
5.       If Cells(i, 8) <> "" Then   '减少多重提取单元格数据判断次数
   
6.         Cells(i, 21) = "1"
   
7.         Cells(i, 23) = "2"
   
8.         Ys = Cells(i, 8).Interior.ColorIndex    '减少对单元格的反复询问
   
9.         If Ys = 40 Then
   
10.             Cells(i, 31) = 10
    
11.             Cells(i, 26) = "d"
    
12.         ElseIf Ys = 44 Then
    
13.             Cells(i, 31) = 50
    
14.             Cells(i, 26) = "b"
    
15.         ElseIf Ys = 45 Then
    
16.             Cells(i, 31) = 60
    
17.             Cells(i, 26) = "c"
    
18.         ElseIf Ys = 46 Then
    
19.             Cells(i, 31) = 70
    
20.             Cells(i, 26) = "a"
    
21.         End If
    
22.       End If
    
23.       Cells(i, 30) = Cells(i, 8).Value
    
24.       Cells(i, 32) = Cells(i, 31) * Cells(i, 30)
    
25.     Next
    
26. End Sub
    

复制代码

dadasdas

无聊的疯子 发表于 2013-2-17 15:27
没有附件,只有这样修改,只能提升一点速度!!

还是发附件吧
从第五行开始，如果H列数据填充色是茶色，那么U列自动填上1，W列填上2，Z列填上b，AD列=H列的值，AE列填上100，然后AD列和AE列数据相加，结果显示在AF列
下面还有三种填充色，看附件里的数据，同上
附件： Book1.rar (2.31 KB, 下载次数: 5)

2013-2-17 15:50 上传

点击文件名下载附件

爱疯

1. 
   
2. Sub test()
   
3.     Dim A, i%
   
4. 
   
5.     With Sheets("sheet1")
   
6.         A = .Range("A4").CurrentRegion
   
7.         For i = 2 To UBound(A)
   
8.             If A(i, 8) <> "" Then
   
9.                 A(i, 21) = "1": A(i, 23) = "2": A(i, 30) = A(i, 8)
   
10.                 Select Case .Cells(i + 3, "H").Interior.ColorIndex
    
11.                 Case 40
    
12.                     A(i, 26) = "d": A(i, 31) = 10
    
13.                 Case 44
    
14.                     A(i, 26) = "b": A(i, 31) = 50
    
15.                 Case 45
    
16.                     A(i, 26) = "c": A(i, 31) = 60
    
17.                 Case 46
    
18.                     A(i, 26) = "a": A(i, 31) = 70
    
19.                 End Select
    
20.                 A(i, 32) = A(i, 30) * A(i, 31)
    
21.             End If
    
22.         Next
    
23.         .Range("A4").Resize(UBound(A), UBound(A, 2)) = A
    
24.     End With
    
25. End Sub
    

复制代码

Book1B.rar (15.21 KB, 下载次数: 4)

2013-2-17 16:44 上传

点击文件名下载附件
照1楼2楼改的

dadasdas

爱疯 发表于 2013-2-17 16:45
照1楼2楼改的

有个问题，H列数据没有填充色，右边也添加了

爱疯

dadasdas 发表于 2013-2-17 16:52
有个问题，H列数据没有填充色，右边也添加了

也添加了，是因上次的运行结果未清除造成的。

不理解哪块区域需事先清除，ad:af么？

Book1c.rar (15.15 KB, 下载次数: 2)

2013-2-17 17:04 上传

点击文件名下载附件

dadasdas

爱疯 发表于 2013-2-17 17:05
也添加了，是因上次的运行结果未清除造成的。

不理解哪块区域需事先清除，ad:af么？

我的意思是只要H列数据没有填充色，右边所有的数据都不要添加

爱疯

Book1d.rar (15.47 KB, 下载次数: 18)

2013-2-17 17:29 上传

点击文件名下载附件

这样可以吗

dadasdas

1. Sub test2()
   
2.     Dim A, i%
   
3. 
   
4.     With Sheets("sheet1")
   
5.         .Range("i5:af65536").ClearContents
   
6.         A = .Range("A4").CurrentRegion
   
7.         For i = 2 To UBound(A)
   
8.             If A(i, 8) <> "" Then
   
9.                 Select Case .Cells(i + 3, "H").Interior.ColorIndex
   
10.                 Case 40
    
11.                     A(i, 26) = "d": A(i, 31) = 10
    
12.                 Case 44
    
13.                     A(i, 26) = "b": A(i, 31) = 50
    
14.                 Case 45
    
15.                     A(i, 26) = "c": A(i, 31) = 60
    
16.                 Case 46
    
17.                     A(i, 26) = "a": A(i, 31) = 70
    
18.                 Case Else
    
19.                     GoTo 100
    
20.                 End Select
    
21.                 A(i, 21) = "1": A(i, 23) = "2": A(i, 30) = A(i, 8)
    
22.                 If A(i, 31) Then A(i, 32) = A(i, 30) * A(i, 31)
    
23.             End If
    
24. 100:
    
25.         Next
    
26.         .Range("A4").Resize(UBound(A), UBound(A, 2)) = A
    
27.     End With
    
28. End Sub
    

复制代码

dadasdas

爱疯 发表于 2013-2-17 17:32
这样可以吗

i + 3是什么意思？