通过一题十解谈拓宽编程思路

彦子2012

学习EXCEL好地方，很值得收藏

风与鱼

感谢楼主分享

RITA_WANG

太强大了，先下载收藏起来，有空学习研究一下。

l123258789

最头痛数组了，觉得很好用，但一直用不好。

白云人家

真不错的东西，学习

iewihz

书山有路勤为径，学海无涯苦作舟！

zxzxcl

楼主你太牛了

huanglicheng

1. Sub test()
   
2.     Dim arr, i%, j%, crr()
   
3.     Dim M_min%, M_max%, M_speed%, X$, n%
   
4.     Dim d As Object, dic As Object
   
5.     '-----------------------------------------------
   
6.     arr = Range("a1:b" & Range("b65536").End(3).Row)
   
7.     n = 1
   
8.     '-----------------------------------------------
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Set dic = CreateObject("scripting.dictionary")
    
11.     '-----------------------------------------------
    
12.     For i = 2 To UBound(arr)
    
13.         d(arr(i, 1)) = d(arr(i, 1)) + 1
    
14.         If Val(arr(i, 1)) <= Val(arr(i - 1, 1)) Then n = n + 1
    
15.         dic(n & ":" & arr(i, 1)) = Array(arr(i, 1), arr(i, 2))
    
16.     Next i
    
17.     '-----------------------------------------------
    
18.     M_max = Application.WorksheetFunction.max(d.keys)
    
19.     M_min = Application.WorksheetFunction.Min(d.keys)
    
20.     M_speed = n
    
21.     '-----------------------------------------------
    
22.     ReDim crr(1 To M_speed * (M_max + 1), 1 To 2)
    
23.     For i = 1 To M_speed
    
24.         For j = M_min To M_max
    
25.             X = i & ":" & j
    
26.             q = q + 1
    
27.             If dic.exists(X) Then
    
28.                 crr(q, 1) = dic(X)(0)
    
29.                 crr(q, 2) = dic(X)(1)
    
30.             Else
    
31.                 crr(q, 1) = j
    
32.             End If
    
33.             If j = M_max Then q = q + 1
    
34.         Next j
    
35.     Next i
    
36.     '-----------------------------------------------
    
37.     Columns("D:F").ClearContents
    
38.     Range("d2").Resize(q, 2) = crr
    
39. 
    
40. End Sub
    

复制代码

试着写了一个

lzqmsy

下载学习,谢谢!!!

FENDOU2013

{:soso_e100:}学习，顶一个。