最接近π值的5位分数的算法

题目:

求一个分数，分子5位数（第1位不是0），分母也是5位数（第1位不是0），分子和分母这10个数正好由0到9这10个数字组成（不缺也不重复）。求最接近π值的那个分数

解法1(穷举法)

Sub getit()
Const num As Long = 3628800 ' 10!
Dim tt As Single, i As Long, j As Long, k As Long, temp1 As Long, temp2 As Long, pi As Single, diff As Single, out As String, temp As String
pi = 4 * Atn(1)
diff = 1
tt = Timer '开始计时
For i = 0 To num - 1
temp = 0
temp1 = i
For j = 2 To 10
temp2 = temp1 Mod j + 1
temp1 = temp1 \ j
temp = Left(temp, temp2 - 1) & j - 1 & Mid(temp, temp2)
Next
If temp Like "[3-9]####[1-3]####" Then
temp1 = Val(Left(temp, 5))
temp2 = Val(Right(temp, 5))
If Abs(temp1 / temp2 - pi) < diff Then diff = Abs(temp1 / temp2 - pi):  out = temp1 & "/" & temp2
End If
Next
MsgBox out & "用时 " & Timer - tt & " 秒！"
End Sub

最后结果:=85910/27346

上述代码效率太低.

解法2(穷举法)

Sub Getit()
Dim pi As Single, diff As Single, i As Long, j As Long, temp As Long, s() As Byte, n As Byte, result As String, tt As Single
tt = Timer
pi = 4 * Atn(1)
diff = 1
    For i = 31425 To 98765
    ReDim s(9)
    For j = 1 To 5
    s(Mid(i, j, 1)) = 1
    Next
    If WorksheetFunction.Sum(s) = 5 Then
         temp = Fix(i / pi)
         For j = 1 To 5
           s(Mid(temp, j, 1)) = 1
         Next
        If WorksheetFunction.Sum(s) = 10 Then
            If Abs(i / temp - pi) < diff Then
              diff = Abs(i / temp - pi)
             result = i & "/" & temp
            End If
        End If
   End If
Next
MsgBox result, vbInformation, "总计用时" & Timer - tt & "秒!"
End Sub

 解法3(递归法)(yier_fang提供,http://club.excelhome.net/dispbbs.asp?boardid=2&replyid=978209&id=262029&page=1&skin=0&Star=1)

 Dim lngFM As Long
    Dim lngFZ As Long
    Const PI = 3.1415926535
    Dim dbl As Double
    Dim kkk As Long
    Dim intCK As Integer
    Dim showW As Boolean
    Dim Unums As String
    Dim Lnums As String
   
   
Sub cnft()
    Dim tm
    tm = Timer
    Application.ScreenUpdating = False
    kkk = 0: lngFM = 0: lngFZ = 0
    Unums = Cells(3, "H")
    Lnums = Cells(3, "I")
    dbl = 3.1415926535
    intCK = Cells(3, "F").Value
    showW = Cells(3, "E").Value
    If showW Then UserForm1.Show
    Call fs("", "")
    Cells(1, 2).Value = lngFZ
    Cells(2, 2).Value = lngFM
    If lngFM = 0 Then
        Cells(3, 2).Value = "无解"
    Else
        Cells(3, 2).Value = (lngFZ / lngFM)
    End If
    Cells(4, 2).Value = kkk
    UserForm1.Hide
    Application.ScreenUpdating = True
    Cells(5, 2) = Format((Timer - tm), "0.0000") & "秒"
End Sub
Sub fs(ByRef FM As String, ByRef FZ As String)
    kkk = kkk + 1
    If showW Then
        UserForm1.TextBox1.Text = "递归第..." & kkk & "...次"
        DoEvents
    End If
    Dim i, j As Long
    If Len(FM) = 0 Then
        For i = 1 To 9
            For j = 1 To 9
                If i <> j Then
                    Call fs(CStr(i), CStr(j))
                End If
            Next j
        Next i
    ElseIf Len(FM) < 5 Then
        If intCK = 1 Then
            If ((FZ - 1) / (FM + 1)) > PI Then Exit Sub
            If FM = 1 Then
                If ((FZ + 1) / (FM)) < PI Then Exit Sub
            Else
                If ((FZ + 1) / (FM - 1)) < PI Then Exit Sub
            End If
        ElseIf intCK = 2 Then
            '=======下面是手工的出口设置=========
            If FZ / FM < Lnums Then Exit Sub
            If FZ / FM > Unums Then Exit Sub
        End If
        For i = 0 To 9
            If InStr(FM & FZ, i) = 0 Then
                For j = 0 To 9
                    If InStr(FM & FZ & i, j) = 0 Then
                        Call fs(FM & i, FZ & j)
                    End If
                Next j
            End If
        Next i
           
    Else
       
        If Abs((FZ / FM) - PI) < dbl Then
            lngFM = FM
            lngFZ = FZ
            dbl = Abs((FZ / FM) - PI)
           
        End If
    End If
End Sub

 解法4(递归法)(彭希仁提供:http://club.excelhome.net/dispbbs.asp?boardid=2&replyid=977506&id=262029&page=1&skin=0&Star=2)

Public pi
Public x
Public y
Public z
Public k As Long
Public st
Sub peng()
    t = Timer
    pi = 4 * Atn(1)
    x = 10
    st = 0
    Call caii("", 0)
    MsgBox (y & "/" & z & "=" & y / z & "递归" & st & "次,耗时" & Timer - t & "秒")
End Sub
Sub caii(a, i)
    st = st + 1
    m = 0
    If i = 1 Then m = 3
    For j = m To 9
        If Not (a Like "*" & j & "*") Then
            If i + 1 = 5 Then
                k = a & j
                If k > 31415 Then
                 kp = Round(k / pi)
                    If Abs(k / kp - pi) < x Then
                        h = k & kp
                        For n = 0 To 9
                            If Not (h Like "*" & n & "*") Then Exit For
                        Next n
                        If n = 10 Then
                            x = Abs(k / kp - pi)
                            y = k
                            z = kp
                        End If
                    End If
                End If
            Else
                Call caii(a & j, i + 1)
            End If
        End If
    Next j
End Sub

 解法5(回溯法)

Sub getit(ByVal target As Single)   'target is a single number between 1～98765\10234
Dim n As Byte, m As Byte
Dim i As Integer, j As Integer, t As Integer, a(), fenmu As Long, fenzi As Long, max As Long, temp As String, result As Long
m = 4: n = 9
diff = 1
tt = Timer
max = int(98765/target)
ReDim a(m)
For i = 1 To m
a(i) = -1
Next
Do
a(t) = a(t) + 1
If a(t) > n Then
t = t - 1
Else
For i = 0 To t - 1
If a(t) = a(i) Then Exit For
Next
If i = t Then
If t = m Then
fenmu = Join(a, "")
fenzi = Round(fenmu * target)
temp = fenzi & "/" & fenmu
If Abs(fenzi / fenmu - target) < diff Then
For j = 0 To 9
If InStr(temp, j) = 0 Then Exit For
Next
If j = 10 Then diff = Abs(fenzi / fenmu - target): result = fenmu
End If
End If
If t < m Then t = t + 1: a(t) = -1
End If
End If
If fenmu > max Then Exit Do
Loop Until t = -1
Debug.Print "Target:     " & target & vbCrLf & "Result:     " & Round(result * target) & "/" & result & vbCrLf & "Error:      " & diff & vbCrLf & "Lapsetime:  " & Format(Timer - tt, "0.00000") & " seconds" & vbCrLf
End Sub

Sub macro1()
getit Sqr(2)
getit Sqr(3)
getit Exp(1)
getit 4 * Atn(1)
getit 5.6789
End Sub

返回:

Target:     1.414214
Result:     95103/67248
Error:      4.76071359769127E-07
Lapsetime:  0.20313 seconds

Target:     1.732051
Result:     93820/54167
Error:      1.03205265816492E-07
Lapsetime:  0.13867 seconds

Target:     2.718282
Result:     87159/32064
Error:      4.39718097983719E-07
Lapsetime:  0.06445 seconds

Target:     3.141593
Result:     85910/27346
Error:      1.79341409058684E-07
Lapsetime:  0.04492 seconds

Target:     5.6789
Result:     95082/16743
Error:      1.08244854411521E-05
Lapsetime:  0.01563 seconds