'添加三件控件,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