vba程序用7重循环来计算24

 

'添加三件控件，F1单元格存放最大值
Sub Cal()
Dim t As Single
Dim Num(1 To 4)
t = Timer
For i = 1 To 4
    If Sheets(1).CheckBox1.Value Then Cells(1, i) = WorksheetFunction.RandBetween(1, Range("F1"))
    Num(i) = Cells(1, i)
Next
r = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A2:B" & r) = ""
Application.ScreenUpdating = False
r = 3
For a = 1 To 4
    For b = 1 To 4
        For c = 1 To 4
            For d = 1 To 4
                For i = 1 To 4
                    For j = 1 To 4
                        For k = 1 To 4
                            If a <> b And a <> c And a <> d And b <> c And b <> d And c <> d Then
                                '无括号的运算
                                Cells(r, 1) = Num(a) & Sign(i) & Num(b) & Sign(j) & Num(c) & Sign(k) & Num(d) & " = "
                                Cells(r, 2) = "=" & Num(a) & Sign(i) & Num(b) & Sign(j) & Num(c) & Sign(k) & Num(d)
                                If Cells(r, 2) = 24 Then r = r + 1
                                '有括号运算（a b）c d
                                Cells(r, 1) = "(" & Num(a) & Sign(i) & Num(b) & ")" & Sign(j) & Num(c) & Sign(k) & Num(d) & " = "
                                Cells(r, 2) = "=" & "(" & Num(a) & Sign(i) & Num(b) & ")" & Sign(j) & Num(c) & Sign(k) & Num(d)
                                If Not IsError(Cells(r, 2)) Then '注意有括号要避免分母为0的情况
                                    If Cells(r, 2) = 24 Then r = r + 1
                                End If
                                '(a b c) d
                                Cells(r, 1) = "(" & Num(a) & Sign(i) & Num(b) & Sign(j) & Num(c) & ")" & Sign(k) & Num(d) & " = "
                                Cells(r, 2) = "=" & "(" & Num(a) & Sign(i) & Num(b) & Sign(j) & Num(c) & ")" & Sign(k) & Num(d)
                                If Not IsError(Cells(r, 2)) Then
                                    If Cells(r, 2) = 24 Then r = r + 1
                                End If
                                'a ( b c) d
                                Cells(r, 1) = Num(a) & Sign(i) & "(" & Num(b) & Sign(j) & Num(c) & ")" & Sign(k) & Num(d) & " = "
                                Cells(r, 2) = "=" & Num(a) & Sign(i) & "(" & Num(b) & Sign(j) & Num(c) & ")" & Sign(k) & Num(d)
                                If Not IsError(Cells(r, 2)) Then
                                    If Cells(r, 2) = 24 Then r = r + 1
                                End If
                                'a (b c d)
                                Cells(r, 1) = Num(a) & Sign(i) & "(" & Num(b) & Sign(j) & Num(c) & Sign(k) & Num(d) & ")" & " = "
                                Cells(r, 2) = "=" & Num(a) & Sign(i) & "(" & Num(b) & Sign(j) & Num(c) & Sign(k) & Num(d) & ")"
                                If Not IsError(Cells(r, 2)) Then
                                    If Cells(r, 2) = 24 Then r = r + 1
                                End If
                                'a b (c d)
                                Cells(r, 1) = Num(a) & Sign(i) & Num(b) & Sign(j) & "(" & Num(c) & Sign(k) & Num(d) & ")" & " = "
                                Cells(r, 2) = "=" & Num(a) & Sign(i) & Num(b) & Sign(j) & "(" & Num(c) & Sign(k) & Num(d) & ")"
                                If Not IsError(Cells(r, 2)) Then
                                    If Cells(r, 2) = 24 Then r = r + 1
                                End If
                                '(a b) (c d)
                                Cells(r, 1) = "(" & Num(a) & Sign(i) & Num(b) & ")" & Sign(j) & "(" & Num(c) & Sign(k) & Num(d) & ")" & " = "
                                Cells(r, 2) = "=" & "(" & Num(a) & Sign(i) & Num(b) & ")" & Sign(j) & "(" & Num(c) & Sign(k) & Num(d) & ")"
                                If Not IsError(Cells(r, 2)) Then
                                    If Cells(r, 2) = 24 Then r = r + 1
                                End If
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
Next
If Cells(r, 2) <> 24 Then Range("A" & r & ":B" & r) = ""
r = Cells(Rows.Count, 1).End(xlUp).Row
If r = 1 Then
    Cells(2, 1) = "此四数无解！"
    Exit Sub
Else
    Cells(2, 1) = "共" & r - 2 & "种解法"
End If

'以下去掉重复解法，如不计重新以下代码除最后2行可以全部删除
'只要公式的字串不同即算一种解法，而不考虑交换律、结合律、运算符等级的实质相同。
For j = r To 4 Step -1
    For i = 3 To j - 1
        If Cells(j, 1) = Cells(i, 1) Then
            Cells(j, 1) = ""
            Cells(j, 2) = ""
        End If
    Next
Next
'以下删除空行后重新计算行数
For i = r To 3 Step -1
    If Cells(i, 1) = "" Then
        Rows(i).Delete
    End If
Next
r = Cells(Rows.Count, 1).End(xlUp).Row
Cells(2, 1) = "共" & r - 2 & "种解法"

'计算时间
Cells(2, 1) = Cells(2, 1) & "，耗时" & Timer - t & "秒。"
Application.ScreenUpdating = True

End Sub

Function Sign(x)
Select Case x
    Case 1: Sign = " + "
    Case 2: Sign = " - "
    Case 3: Sign = " * "
    Case 4: Sign = " / "
End Select
End Function