[已解决]请老师们帮忙改代码

ping052062

请老师们帮忙改代码！详情看附件。
请老师帮忙改代码.zip (8.14 KB, 下载次数: 11)

2013-8-5 08:49 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-8-5 09:39

偷懒了，用单元格操作完成，数据量大时速度慢

1. Sub aa1()
   
2. Dim i%, j%, k%, l%, m%, Arr, ii&
   
3. Arr = Range("C1:D17")
   
4. For ii = 2 To UBound(Arr)
   
5.     i = Int(Arr(ii, 1))
   
6.     j = Int(Arr(ii, 2))
   
7.     If i = 0 Or j = 0 Then GoTo 100
   
8.     Cells(ii, 5).Resize(1, 4).Interior.ColorIndex = 1
   
9.     k = j - i + 5
   
10.     If k < 5 Then k = k + 4
    
11.     Cells(ii, k).Interior.ColorIndex = 5
    
12.     m = 1
    
13.     For l = 1 To 4 - j
    
14.         If k + m > 8 Then m = m - 4
    
15.         Cells(ii, k + m).Interior.ColorIndex = 3
    
16.         m = m + 1
    
17.     Next l
    
18. 100:
    
19.   For i = 5 To 8
    
20.     If Cells(ii, 3) <> "" Then Cells(ii, i) = IIf(Cells(ii, 3) + i - 5 > 4, Cells(ii, 3) + i - 9, Cells(ii, 3) + i - 5)
    
21.   Next i
    
22. Next
    
23. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

偷懒了，用单元格操作完成，数据量大时速度慢

1. Sub aa1()
   
2. Dim i%, j%, k%, l%, m%, Arr, ii&
   
3. Arr = Range("C1:D17")
   
4. For ii = 2 To UBound(Arr)
   
5.     i = Int(Arr(ii, 1))
   
6.     j = Int(Arr(ii, 2))
   
7.     If i = 0 Or j = 0 Then GoTo 100
   
8.     Cells(ii, 5).Resize(1, 4).Interior.ColorIndex = 1
   
9.     k = j - i + 5
   
10.     If k < 5 Then k = k + 4
    
11.     Cells(ii, k).Interior.ColorIndex = 5
    
12.     m = 1
    
13.     For l = 1 To 4 - j
    
14.         If k + m > 8 Then m = m - 4
    
15.         Cells(ii, k + m).Interior.ColorIndex = 3
    
16.         m = m + 1
    
17.     Next l
    
18. 100:
    
19.   For i = 5 To 8
    
20.     If Cells(ii, 3) <> "" Then Cells(ii, i) = IIf(Cells(ii, 3) + i - 5 > 4, Cells(ii, 3) + i - 9, Cells(ii, 3) + i - 5)
    
21.   Next i
    
22. Next
    
23. End Sub

复制代码

ping052062

非常感谢！老师你给做个优化的好吗？