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

香川群子

yjh_27 发表于 2013-3-28 20:39
第12种解法

对15楼 yjh_27 代码的一些改进：

1. Sub Macro13() 'yjh_27 算法改进 by kagawa
   
2.     Dim i&, j&, k&, m&, n&
   
3.     m = Range("A65536").End(3).Row
   
4.     arr = Range("A2").Resize(m, 2) '这里比实际数据多取1行，以后可以省去一层判断
   
5.     n = Application.max(Range("A2").Resize(m))
   
6.     '取巧，用工作表Max函数得到A列中【组的最大值】，本例=4。这样做就有通用性了。
   
7.     '以后每组5个、6个……10个都可以处理，不需要改代码了。
   
8. 
   
9.     ReDim brr(1 To m / 2 * (n + 1), 1 To 3) '这里/2处理是为了定义数组不要太浪费内存。
   
10.     i = 1
    
11.     Do
    
12.         For j = 1 To n
    
13.             k = k + 1
    
14.             brr(k, 1) = j
    
15.             '改进1： 在这里省略了If n <= UBound(arr) Then的判断
    
16.             If arr(i, 1) = j Then
    
17.                 brr(k, 2) = arr(i, 2)
    
18.                 brr(k, 3) = i + 1   '列号
    
19.                 i = i + 1
    
20.             End If
    
21.         Next
    
22.         If i = m Then Exit Do
    
23.         k = k + 1
    
24.     Loop
    
25. '    [d:f] = ""
    
26.     Range("D2").Resize(k, 3) = brr
    
27. End Sub
    

复制代码

因为减少了一层判断，所以速度可以提高一些。

香川群子

我的数组算法-1：

第一循环，整理数据arr到数组brr
格式如下：
列号    0  1  2 ……
行1     1      1 ……
行2     2  2  2 ……
行3     3  3  3 ……
行4         4    ……
行5      ……    ……
……

即，把原始数据横向展开。

这样，根据整理结果自然地得到【组的最大值】=brr有效行数，以及【实际组数】=brr有效列数。
第二循环再把brr结果转换为需要输出的纵向数组crr

1. Sub kagawa1()
   
2.     Dim i&, j&, k&, m&, n&, r&, c&
   
3.     m = Range("A65536").End(3).Row - 1
   
4.     arr = Range("A2").Resize(m, 2)
   
5. 
   
6.     ReDim brr(m / 2, m)
   
7.     For i = 1 To m
   
8.         If arr(i, 1) < r Then c = c + 1
   
9.         r = arr(i, 1): If r > n Then n = r
   
10.         brr(r, c) = arr(i, 2)
    
11.     Next
    
12. 
    
13.     ReDim crr(1 To (n + 1) * (c + 1), 1 To 2)
    
14.     For j = 0 To c
    
15.         k = k + 1
    
16.         For i = 1 To n
    
17.             k = k + 1
    
18.             crr(k, 1) = i
    
19.             crr(k, 2) = brr(i, j)
    
20.         Next
    
21.     Next
    
22. '    [d:e] = ""
    
23.      Range("D1").Resize(k, 2) = crr
    
24. End Sub

复制代码

香川群子

下面是直接一层循环就把结果整理到数组brr然后直接输出的代码。

由于过程中会出现3种不同的类型，所以看上去代码稍显复杂。
但运行效率相当不错。

1. Sub kagawa2()
   
2.     Dim i&, j&, k&, m&, n&, r&, t&
   
3.     m = Range("A65536").End(3).Row - 1
   
4.     arr = Range("A2").Resize(m, 2)
   
5.     n = Application.max(Range("A2").Resize(m))
   
6.    
   
7.     ReDim brr(m / 2 * n, 1)
   
8.     r = 1: k = 1
   
9.     For i = 1 To m
   
10.         t = arr(i, 1)
    
11.         If t > r Then
    
12.             For j = r To t - 1
    
13.                 brr(k, 0) = j
    
14.                 k = k + 1
    
15.             Next
    
16.         ElseIf t < r Then
    
17.             For j = r To n
    
18.                 brr(k, 0) = j
    
19.                 k = k + 1
    
20.             Next
    
21.             k = k + 1
    
22.             For j = 1 To t - 1
    
23.                 brr(k, 0) = j
    
24.                 k = k + 1
    
25.             Next
    
26.         End If
    
27.         brr(k, 0) = t
    
28.         brr(k, 1) = arr(i, 2)
    
29.         k = k + 1
    
30.         r = t + 1
    
31.     Next
    
32.     For j = r To n
    
33.         brr(k, 0) = j
    
34.         k = k + 1
    
35.     Next
    
36. '    [d:e] = ""
    
37.      Range("D1").Resize(k, 2) = brr
    
38. End Sub

复制代码

香川群子

上传附件。到目前为止有12种代码 加上我的3个(其中一个是对15楼 yjh_27 的算法改进)

因此一共是13种代码了。

如果以速度考量，那么前面10种代码都没啥优势。呵呵。

时光鸟

香川群子 发表于 2013-4-4 14:59
上传附件。到目前为止有12种代码 加上我的3个(其中一个是对15楼 yjh_27 的算法改进)

因此一共是13种代码 ...

代码2本来没有BUG的，被你这么一改还改出BUG来了~

whong003

我就喜欢这种 doitbest 和香川群子 高水平选手

在代码正确性的前提下，追求代码的通用性和效率

水平差点的能正确运行凑合一下过渡一下也行，到达一定水平了，应该另有追求

香川群子

时光鸟 发表于 2013-4-4 15:27
代码2本来没有BUG的，被你这么一改还改出BUG来了~

应该没有bug 不过是我把清空结果区域的那一句代码注释掉了……因为比较速度时这一句代码比较耗时。

所以直接输出结果时看上去像是有错误而已。其实没有错误。

时光鸟

香川群子 发表于 2013-4-4 20:48
应该没有bug 不过是我把清空结果区域的那一句代码注释掉了……因为比较速度时这一句代码比较耗时。

所 ...

1. '      If v1 < maxNum And i > 2 Then
   
2.            If v1 < maxNum Then

复制代码

1.   '       If i > 2 Then k = k + 1
   
2.            k = k + 1

复制代码

我说的是这两个地方，不能去掉对 i>2 的判断~

香川群子

时光鸟 发表于 2013-4-4 20:58
我说的是这两个地方，不能不去掉对 i>2 的判断~

哦。这里我是想试一试，去掉这个判断对速度有多大影响。……

因为楼主附件例子ID是从1开始的，这样改对结果不会有影响……。

…………

不过，如果附件数据有变化的话，10个代码中其它几个本身就会运行得到错误的结果……

比如说，把A2的ID改成从2开始(原来是从1开始)
那么，P1、P4和P7运行结果都是错误的。
而P9和P10直接就无法运行了。
……
所以我就不考虑这个问题了。
在大家一样的基础上比较就行了。

香川群子

时光鸟 发表于 2013-4-4 20:58
我说的是这两个地方，不能去掉对 i>2 的判断~

P2代码是你的出品么……呵呵。

为啥用： maxNum = Application.max(maxNum, arrPre(i, 1)) 来求最大值，
直接用 If arrPre(i, 1)>maxNum Then maxNum = arrPre(i, 1) 不是更简明么。

难道在VBA中使用工作表Max()函数有额外的好处？