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

doitbest

方法9
此方案是用单元格读取实现的，1234的分组序号与A列数字共同构成了D列的数据，这里1234的分组序号起到了辅助列的作用，为此后的FIND查找打下基础。在完成其使命后，通过REPLACE替换，将分组序号删除。从十个示例的展示可以看出，单元格操作相比数组，尽管速度比较慢是主要缺点，但其能够充分借助函数、VBA方法、属性，表现出高度的灵活性，而数组一般只能借助循环、判断和少量的数组函数。因此，在解决实际问题时，并不一定唯数组马首是瞻，而要视具体情况灵活应用各种手段。一般来说，高手们往往固执于数组的应用，就有些僵化了。
Public Sub p9()
Dim rng As Range, i, max, x As Range, n
[d:e] = ""
Set rng = Range([a2], [a65536].End(3))
max = Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))")
For i = 1 To max
    IIf([d1] = "", [d1], [d65536].End(3).Offset(2)).Resize(4) = Application.Transpose(Array(i & "," & 1, i & "," & 2, i & "," & 3, i & "," & 4)) ‘将1234与组序号连接起来，读入D列
Next
n = 1
For i = 2 To [a65536].End(3).Row
    If Cells(i, 1) <> (Val(Cells(i - 1, 1)) + 1) Then n = n + 1 ‘如果A列单元格数字不连续
    Set x = [d:d].Find(n & "," & Cells(i, 1), , , 1) ‘在D列查找确定行号，查找值为1234与组序号的连接字符串
    x.Offset(, 1) = Cells(i, 2)
Next
[d:d].Replace "*,", "", 2  ‘用替换删除组序号
End Sub

doitbest

方法10
此方案明显是方法9的数组版。方法8、9、10的思路基本一致，差别在于分别用字典、单元格操作及数组实现。
Public Sub p10()
Dim rng As Range, i, j, max, ar, br(), cr, n, r
[d:e] = ""
Set rng = Range([a2], [a65536].End(3))
ar = Range([a1], [b65536].End(3))
max = Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))")
ReDim br(1 To max * 5, 1 To 2)
For i = 1 To max ‘通过双层循环将组序号与1234的连接字符串读入数组第一列
    n = n + 5
    For j = 4 To 1 Step -1
        br(n - j, 1) = n / 5 & "," & 5 - j
    Next
Next
cr = Application.Index(br, , 1)
n = 1
For i = 2 To UBound(ar)
    If ar(i, 1) <> (Val(ar(i - 1, 1)) + 1) Then n = n + 1 ‘如果数组相邻值不连接，则组序号加1
    r = Application.Match(n & "," & ar(i, 1), cr, 0) ‘用MATCH查找确定行号，查找值为组序号与1234的连接字符串
    br(r, 2) = ar(i, 2)
Next
[d1].Resize(UBound(br), 2) = br
[d:d].Replace "*,", "", 2 ‘用替换删除组序号
End Sub

zhaogang1960

直看得是眼花缭乱，还不知道原要求是什么，凑了一个数组的，看看是否符合要求：

1. Sub Macro1()
   
2.     Dim arr, brr(), i&, j&, m&
   
3.     arr = Range("A2:B" & Range("A65536").End(xlUp).Row)
   
4.     ReDim brr(1 To UBound(arr) * 2, 1 To 2)
   
5.     For i = 1 To UBound(arr) Step 3
   
6.         For j = i To i + 2
   
7.             brr(arr(j, 1) + m, 2) = arr(j, 2)
   
8.         Next
   
9.         For j = 1 To 4
   
10.             m = m + 1
    
11.             brr(m, 1) = j
    
12.         Next
    
13.         m = m + 1
    
14.     Next
    
15.     Columns("D:F").ClearContents
    
16.     [d2].Resize(m, 2) = brr
    
17. End Sub
    

复制代码

doitbest

谢谢版主关注，代码完全符合要求！第11种解法出来了，新的解法还会远吗？
另外，代码加格式总出错，索性就直接贴上来了，有些乱，非常不方便观看，也请大家谅解。

yjh_27

第12种解法

1. Public Sub p12() Dim arr, brr(), i, m, n
   
2. arr = Range("a2:b" & [a65536].End(3).Row)
   
3. ReDim brr(1 To UBound(arr) * 5, 1 To 3)
   
4. n = 1
   
5. Do While n <= UBound(arr)
   
6.     For i = 1 To 4
   
7.         m = m + 1
   
8.         brr(m, 1) = i
   
9.         If n <= UBound(arr) Then
   
10.             If arr(n, 1) = i Then
    
11.                 brr(m, 2) = arr(n, 2)
    
12.                 brr(m, 3) = n + 1   'a2  +1
    
13.                 n = n + 1
    
14.             End If
    
15.         End If
    
16.     Next
    
17.     m = m + 1
    
18. Loop
    
19. Range("d2").Resize(m, 3) = brr
    
20. Erase arr, brr
    
21. End Sub
    

复制代码

xminli

感觉像看天书，差句太大了

doitbest

xminli 发表于 2013-4-3 19:57
感觉像看天书，差句太大了

都这这么过来的，一句句啃完后，就长胖了

大树_zhao

留个脚印，下次来学

bluexuemei

大师似乎忘了介绍这个题目的要求，一头雾水！

doitbest

抱歉，我以为要求简单就没有特别说明，看一下二楼图片右侧即为结果和要求