九宫格 也就是魔方阵 ，用递归写了一个，我无法继续优化
九宫格 也就是魔方阵 ，用递归写了一个，我无法继续优化
程序代码：Option Explicit
Private Type 数据类型
Value As Long '当前值
Hw() As Long '范围
Index As Long '当前范围指针
Count As Long '范围总数
End Type
Dim AA() As 数据类型
Dim MFJ As Long
Dim MFG As Long
Private Sub Command1_Click()
Text1.Text = ""
MFJ = val(Text2.Text)
If MFJ < 3 Then MFJ = 3
MFG = MFJ * MFJ
ReDim AA(MFG)
Dim i As Long
Dim j As Long
Dim js As Long
Dim js2 As Long
For i = 1 To MFG
ReDim AA(i).Hw(MFG)
AA(1).Hw(i) = i '第一个元素的范围是全满
AA(i).Index = 1 '指针均先指向1
Next i
AA(1).Count = MFG '第一个元素永远是满范围
'第一个元素
AA(1).Index = 1
AA(1).Value = AA(1).Hw(AA(1).Index)
For j = 2 To MFG '求后面的元素的范围
Call 计算范围(j)
Next j
js = 0 '结果个数计数
i = 0 '显示进度用
'js2 = 0
'此循环次数是： MFG阶乘 次，已是最优化结果了
Do
'js2 = js2 + 1
If 是否相等 Then
js = js + 1
Call 输出结果
End If
If i <> AA(1).Index Then
Label1 = "进度:" & AA(1).Index
DoEvents
End If
'Label3.Caption = js2
'DoEvents
Loop While 索引加(MFG)
Label2.Caption = "结果总数：" & js
End Sub
Private Function 索引加(cs As Long) As Boolean
AA(cs).Index = AA(cs).Index + 1
If AA(cs).Index > AA(cs).Count Then
If cs > 1 Then
索引加 = 索引加(cs - 1)
Call 计算范围(cs)
Else
索引加 = False
End If
Else
AA(cs).Value = AA(cs).Hw(AA(cs).Index)
索引加 = True
End If
End Function
Private Sub 计算范围(cs As Long)
Dim i As Long, j As Long
Dim b() As Long
ReDim b(MFG)
'生成所有可能
For i = 1 To MFG
b(i) = i
Next i
'去掉已出现了的数据
For i = 1 To cs - 1
For j = 1 To MFG
If b(j) = AA(i).Value Then
b(j) = 0
Exit For
End If
Next j
Next i
'计数，剩下多少数据
j = 0
For i = 1 To MFG
If b(i) > 0 Then
j = j + 1
End If
Next i
'初始化范围大小，设置总数，索引
ReDim AA(cs).Hw(j)
AA(cs).Count = j
AA(cs).Index = 1
'填写范围
j = 0
For i = 1 To MFG
If b(i) > 0 Then
j = j + 1
AA(cs).Hw(j) = b(i)
End If
Next i
AA(cs).Value = AA(cs).Hw(1)
End Sub
Private Sub Form_Load()
MFJ = 3
End Sub
Private Function 是否相等() As Boolean
'是否符合魔方阵的情况，横竖相等，对角线也等
Dim i As Long, j As Long
Dim k As Long, o As Long
Dim js As Long
是否相等 = True
For i = 1 To MFJ '第一个值
k = k + AA(i).Value
Next i
For i = 2 To MFJ '行
o = 0
For j = 1 To MFJ
o = AA((i - 1) * MFJ + j).Value + o
Next j
If o = k Then
js = js + 1
Else
是否相等 = False
Exit Function
End If
Next i
For i = 1 To MFJ '竖
o = 0
For j = 1 To MFJ
o = AA(i + (j - 1) * MFJ).Value + o
Next j
If o = k Then
js = js + 1
Else
是否相等 = False
Exit Function
End If
Next i
o = 0
For i = 1 To MFJ '对角线1
o = o + AA(i * MFJ - i + 1).Value
Next i
If o = k Then
js = js + 1
Else
是否相等 = False
Exit Function
End If
o = 0
For i = 1 To MFJ '对角线2
o = o + AA((i - 1) * MFJ + i).Value
Next i
If o = k Then
js = js + 1
Else
是否相等 = False
Exit Function
End If
End Function
Private Sub 输出结果()
Dim i As Long
Dim s As String
Dim s2 As String
For i = 1 To MFG
s = s & AA(i).Value & " "
If i Mod MFJ = 0 Then
s = s & vbCrLf
End If
Next i
s = s & String(3 * MFJ, "-")
s2 = Text1.Text
If Len(s2) > 0 Then
s2 = s2 & vbCrLf & s
Else
s2 = s
End If
Text1.Text = s2
End Sub
请论坛牛的人，帮忙优化，减少循环次数。
