VBA通过二个题目加深对数组赋值的理解-----蛇形矩阵和螺旋矩阵，详情见附件

香川群子

顺时针或逆时针螺旋

1. 
   
2. Sub test2() 'by kagawa 顺时针或逆时针螺旋
   
3.     Dim i&, ii&, j&, jj&, k&, l&, ll&, n&, t&, tt&, x&, y&, z&
   
4.    
   
5.     [a1].CurrentRegion = ""
   
6.     x = InputBox("行数x=", , Int(Rnd * 50 + 5))
   
7.     y = InputBox("列数y=", , Int(Rnd * 25 + 3))
   
8.     z = MsgBox("螺旋方向z=： Yes 顺时针 / No 逆时针", vbYesNo)
   
9.     ReDim a(1 To x, 1 To y)
   
10.    
    
11.     If z = vbYes Then
    
12.         i = 1: j = 0: If y < x Then n = y * 2 - 1 Else n = x * 2 - 2
    
13.     Else
    
14.         i = 0: j = 1: If x < y Then n = x * 2 - 1 Else n = y * 2 - 2
    
15.     End If
    
16.     '以上计算最大折曲次数 (直线次数-1)
    
17.     r = Array(0, 1, 0, -1) '折曲时行、列增量的变化规律
    
18.    
    
19.     For t = 0 To n '遍历每一次直线过程
    
20.         tt = (t + 1) \ 2 '本次总长度减量
    
21.         If z = vbYes Then
    
22.             ii = r(t Mod 4): jj = r((t + 1) Mod 4)
    
23.             ll = IIf(t Mod 2, x - tt, y - tt)
    
24.         Else
    
25.             ii = r((t + 1) Mod 4): jj = r(t Mod 4)
    
26.             ll = IIf(t Mod 2, y - tt, x - tt)
    
27.         End If
    
28.         '以上计算每一直线状态的行增量、列增量 以及有效长度
    
29. 
    
30.         For l = 1 To ll '按有效长度递增
    
31.             i = i + ii: j = j + jj
    
32.             k = k + 1: a(i, j) = k
    
33.             [a1].Resize(x, y) = a '直接观察 输出结果到工作表 (要速度时这句注释掉)
    
34.         Next
    
35.     Next
    
36. 
    
37.     Application.StatusBar = x & " x " & y & " = " & x * y
    
38.     [a1].Resize(x, y) = a '输出结果到工作表
    
39.     [a1].Cells(i, j).Activate '光标停留到中央最后位置
    
40. End Sub
    

复制代码

香川群子

浮华、缠绕指尖 发表于 2014-3-31 14:27
嗯，其实整体思路是没变的，你的代码的亮点在于辅助数组r=Array(0,1,0,-1)，这个用得是非常好，代替了他们 ...

速度比较：

x= 50 y= 50
Run Count: 10,000
Test1: 4.2656s   我的Do循环
Test2: 3.1055s   我的直接增量计算
Test3: 6.8008s   lsdongjh的Do循环
Test4: 3.6563s   16楼[141475046]的四角推进算法
--End--


我的代码中
r = Array(0, 1, 0, -1)  
改成
Dim r&(3): r(1) = 1: r(3) = -1

速度能稍快一些


…………
16楼[141475046]的四角推进算法，也很有意思，尤其是顺时针、逆时针的转换毫不费力。
但缺点是：只能做正方形矩阵，暂时还无法处理长方形矩阵。（需要边长不等的计算和处理）

香川群子

四角推进法的长方矩形代码：

暂时只做了顺时针的。

1. Sub test() 循环演示
   
2.     Dim i&, j&
   
3.     For i = 1 To 12
   
4.         For j = 1 To 12
   
5.             Call test4(i, j)
   
6.         Next
   
7.     Next
   
8. End Sub
   
9. 
   
10. Sub test4(x&, y&) '代码过程
    
11.     Dim i&, ii&, j&, jj&, k&, l&, ll&, n&, t&, tt& ', x&, y&, z&
    
12.    
    
13.     [a1].CurrentRegion = ""
    
14. '    x = InputBox("行数x=", , Int(Rnd * 50 + 5))
    
15. '    y = InputBox("列数y=", , Int(Rnd * 25 + 3))
    
16. '    z = MsgBox("螺旋方向z=： Yes 顺时针 / No 逆时针", vbYesNo)
    
17.    
    
18. 
    
19.     ReDim a&(1 To x, 1 To y)
    
20.     If x < y Then r = x Else r = y
    
21.     r1 = 1: c1 = 1: r2 = x: c2 = y: k1 = 1: k2 = k1 + x + y - 2
    
22.     For n = 1 To r - 1 Step 2
    
23.         For j = 0 To c2 - c1 - 1
    
24.             Cells(r1, c1 + j) = k1 + j
    
25.             Cells(r2, c2 - j) = k2 + j
    
26.         Next
    
27.         k1 = k1 + j: k2 = k2 + j
    
28.         For j = 0 To r2 - r1 - 1
    
29.             Cells(r1 + j, c2) = k1 + j
    
30.             Cells(r2 - j, c1) = k2 + j
    
31.         Next
    
32.         k1 = k2 + j: k2 = k1 + x + y - n * 2 - 4
    
33.         r1 = r1 + 1: c1 = c1 + 1: r2 = r2 - 1: c2 = c2 - 1
    
34.     Next
    
35.     If c1 > 1 Then Cells(r2 - j + 2, c1 - 1).Activate
    
36.    
    
37.     If r Mod 2 Then
    
38.         If x < y Then
    
39.             For j = 0 To c2 - c1
    
40.                 Cells(r1, c1 + j) = k1 + j
    
41.             Next
    
42.             Cells(r1, c1 + j - 1).Activate
    
43.         Else
    
44.             For j = 0 To r2 - r1
    
45.                 Cells(r1 + j, c2) = k1 + j
    
46.             Next
    
47.             Cells(r1 + j - 1, c2).Activate
    
48.         End If
    
49.     End If
    
50. End Sub
    

复制代码

如改成存入数组，则运算速度快。

浮华、缠绕指尖

香川群子 发表于 2014-4-1 00:13
四角推进法的长方矩形代码：

暂时只做了顺时针的。如改成存入数组，则运算速度快。

非常感谢裙子，有心了

香川群子

顺时针和逆时针，只要通过转置就可以了。

1. Sub test44()
   
2.     Dim i&, j&, k1&, k2&, r1&, c1&, r2&, c2&, r&, n&, x&, y&, z&
   
3.    
   
4.     [a1].CurrentRegion = ""
   
5.     x = InputBox("行数x=", , Int(Rnd * 50 + 5))
   
6.     y = InputBox("列数y=", , Int(Rnd * 25 + 3))
   
7.     z = MsgBox("螺旋方向z=： Yes ??? / No 逆??", vbYesNo)
   
8.     If z = vbNo Then r = x: x = y: y = r
   
9. 
   
10.     ReDim a&(1 To x, 1 To y)
    
11.     If x < y Then r = x Else r = y
    
12.     r1 = 1: c1 = 1: r2 = x: c2 = y: k1 = 1: k2 = k1 + x + y - 2
    
13.     For n = 1 To r - 1 Step 2
    
14.         For j = 0 To c2 - c1 - 1
    
15.             a(r1, c1 + j) = k1 + j
    
16.             a(r2, c2 - j) = k2 + j
    
17.         Next
    
18.         k1 = k1 + j: k2 = k2 + j
    
19.         For j = 0 To r2 - r1 - 1
    
20.             a(r1 + j, c2) = k1 + j
    
21.             a(r2 - j, c1) = k2 + j
    
22.         Next
    
23.         k1 = k2 + j: k2 = k1 + x + y - n * 2 - 4
    
24.         r1 = r1 + 1: c1 = c1 + 1: r2 = r2 - 1: c2 = c2 - 1
    
25.     Next
    
26.     If c1 > 1 Then If z = vbYes Then Cells(r2 - j + 2, c1 - 1).Activate Else Cells(c1 - 1, r2 - j + 2).Activate
    
27.    
    
28.     If r Mod 2 Then
    
29.         If x < y Then
    
30.             For j = 0 To c2 - c1
    
31.                 a(r1, c1 + j) = k1 + j
    
32.             Next
    
33.             If z = vbYes Then Cells(r1, c1 + j - 1).Activate Else Cells(c1 + j - 1, r1).Activate
    
34.         Else
    
35.             For j = 0 To r2 - r1
    
36.                 a(r1 + j, c2) = k1 + j
    
37.             Next
    
38.             If z = vbYes Then Cells(r1 + j - 1, c2).Activate Else Cells(c2, r1 + j - 1).Activate
    
39.         End If
    
40.     End If
    
41.     Application.StatusBar = x & " x " & y & " = " & x * y
    
42.     If z = vbYes Then [a1].Resize(x, y) = a Else [a1].Resize(y, x) = Application.Transpose(a)
    
43. End Sub

复制代码

香川群子

yjh_27 也写了代码，链接在这里
http://club.excelhome.net/forum. ... id=1109068#lastpost

MRHUANGHESIR

不錯，代碼簡潔，運行正確 ，學習

jinhaitiao16

再顶一个,蛇形矩阵和螺旋矩阵