[已解决]求优化下代码

oiufg

book5.rar (338.71 KB, 下载次数: 12)

2015-3-4 09:11 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-5 05:09

oiufg 发表于 2015-3-4 17:24
那你验证第一个结果看下

原来代码结果是错误的，开始的1-6列并没有正确结果
附件给出了开始的列数，楼主自己验证一下

跳转到最佳答案楼层

为何不用E立方管理平台实现？又简单又方便。唉

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 1), d, j%, jj%, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("f3").CurrentRegion
   
5. For j = 1 To UBound(arr, 2) - 5
   
6.     s = 0
   
7.     For jj = j To j + 5
   
8.         s = s + 1
   
9.         For i = 1 To UBound(arr)
   
10.             If Not d.exists(arr(i, jj)) Then
    
11.                 d(arr(i, jj)) = s
    
12.             Else
    
13.                 If InStr(d(arr(i, jj)), s) = 0 Then
    
14.                     d(arr(i, jj)) = d(arr(i, jj)) & s
    
15.                 End If
    
16.                 If Len(d(arr(i, jj))) = 6 Then n = n + 1: brr(n, 1) = arr(i, jj)
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     d.RemoveAll
    
21. Next
    
22. [a:a] = ""
    
23. Range("a1").Resize(n) = brr
    
24. End Sub

复制代码

oiufg

dsmch 发表于 2015-3-4 10:40

结果不对呀

oiufg

oiufg 发表于 2015-3-4 10:59
结果不对呀

把你我的第一个结果在数据里查找一下就看得出问题

grf1973

所谓的连续6列不要求在同一行吧？

grf1973

1. Sub tttt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Range("f3").CurrentRegion
   
4.     For j = 1 To UBound(arr, 2)
   
5.         For i = 1 To UBound(arr)
   
6.             x = arr(i, j)
   
7.             If Not d.exists(x) Then
   
8.                 d(x) = "," & j & ","
   
9.             Else
   
10.                 If InStr(d(x), "," & j & ",") = 0 Then d(x) = d(x) & j & ","
    
11.             End If
    
12.         Next
    
13.     Next
    
14.    
    
15.     ReDim brr(1 To d.Count, 1 To 2)
    
16.     dk = d.keys: dt = d.items
    
17.     For i = 1 To d.Count
    
18.         x = dk(i - 1): y = dt(i - 1)
    
19.         xstr = ""
    
20.         For j = 1 To UBound(arr, 2) - 5
    
21.             xstr = "," & j & "," & j + 1 & "," & j + 2 & "," & j + 3 & "," & j + 4 & "," & j + 5 & ","
    
22.             If InStr(y, xstr) > 0 Then
    
23.                 n = n + 1
    
24.                 brr(n, 1) = "'" & x
    
25.                 brr(n, 2) = Mid(xstr, 2, Len(xstr) - 2)
    
26.                 Exit For
    
27.             End If
    
28.         Next
    
29.     Next
    
30.     [a:b].Clear
    
31.     [a1] = "值": [b1] = "连续列"
    
32.     Range("a2").Resize(d.Count, 2) = brr
    
33. End Sub

复制代码

oiufg

grf1973 发表于 2015-3-4 14:29

我举个例吧,如果f3:f1842里有"000"(不管有几个), g3:g1842里也有000, h3:h1842里也有, i3:i1842里也有, j3:j1842里也有,
k3:k1842里也有, 这样就是连续六列都有相同数,放a例, g到l,h到m等都一样

grf1973

嗯，7楼代码就是这个意思。我在B列列出了该数最先出现连续6列的列号

oiufg

grf1973 发表于 2015-3-4 16:43
嗯，7楼代码就是这个意思。我在B列列出了该数最先出现连续6列的列号

那你验证第一个结果看下