[已解决]请老师帮助解决这个问题

yizhih

请老师帮助解决这个问题，谢谢！
提取数字距离.rar (8.75 KB, 下载次数: 9)

2013-4-14 17:57 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2013-4-14 18:53

1. Private Sub CommandButton1_Click()
   
2.     Dim A, x, rng, r%, i%, j%
   
3.    
   
4.     r = Range("y65536").End(xlUp).Row
   
5.     A = Range("b1:y" & r)
   
6. 
   
7.     For i = 1 To r
   
8.         If A(i, 1) <> "" Then x = A(i, 1)
   
9.         For j = 9 To 24
   
10.             If A(i, j) = x Then A(i, 2) = j - 8: Exit For
    
11.         Next j
    
12.     Next i
    
13. 
    
14.     i = 0
    
15.     Set rng = [aa1].Resize(r / 6, 6)
    
16.     For Each x In rng
    
17.         i = i + 1
    
18.         rng(i) = A(i, 2)
    
19.     Next
    
20. End Sub
    
21. 
    

复制代码

跳转到最佳答案楼层

爱疯

1. Private Sub CommandButton1_Click()
   
2.     Dim A, x, rng, r%, i%, j%
   
3.    
   
4.     r = Range("y65536").End(xlUp).Row
   
5.     A = Range("b1:y" & r)
   
6. 
   
7.     For i = 1 To r
   
8.         If A(i, 1) <> "" Then x = A(i, 1)
   
9.         For j = 9 To 24
   
10.             If A(i, j) = x Then A(i, 2) = j - 8: Exit For
    
11.         Next j
    
12.     Next i
    
13. 
    
14.     i = 0
    
15.     Set rng = [aa1].Resize(r / 6, 6)
    
16.     For Each x In rng
    
17.         i = i + 1
    
18.         rng(i) = A(i, 2)
    
19.     Next
    
20. End Sub
    
21. 
    

复制代码

yizhih

爱疯 发表于 2013-4-14 18:53

万分感谢 爱疯老师，非常好，如果您有时间，请您将J:Y中与B列相同的数字变成红色的代码加上，再次感谢！

爱疯

yizhih 发表于 2013-4-14 22:57
万分感谢 爱疯老师，非常好，如果您有时间，请您将J:Y中与B列相同的数字变成红色的代码加上，再次感谢！

条件格式不是挺好的么？
不知道为什么再去另写

大灰狼1976

LZ要用VBA填色，想必有这个需要，请参考附件。
有两个按钮，原按钮放的是爱疯老师的代码，不过我自作主张加上了填色功能；
另一个新增按钮是我编写的代码。
结论：爱疯老师的代码速度比较快，计算结果我们差1。

yizhih

大灰狼1976 发表于 2013-4-17 20:36
LZ要用VBA填色，想必有这个需要，请参考附件。
有两个按钮，原按钮放的是爱疯老师的代码，不过我自作主张加 ...

非常感谢大灰狼1976 老师，您的代码非常好，解决了我很大的问题。

大灰狼1976

我不是老师，谢谢夸奖
我以前用ACCESS比较多，但是也只会一点皮毛，现在公司没有ACCESS，才开始学习
EXCEL和VBA的，希望能够相互支持，共同努力。