Private Sub Command1_Click() '快速除法程序
Dim a, B
a = Trim(Text1): B = Trim(Text2): b3 = B: a3 = a
ts = Timer
If Len(B) = 1 Then
X1 = Mid(B, 1, 1): X2 = 1 / X1 - 0.01
Else
X1 = Mid(B, 1, 2): X2 = 10 / X1 - 0.01
End If
x = Mid(X2, 1, 4)
Y = 0: x3 = 0
sb = Len(a3) + Len(b3) - 1 + 2
If Len(a3) = Len(b3) And MBJC(Trim(a3), Trim(b3)) = 0 Then
a1 = 1
ElseIf MBJC(Mid(a3, 1, Len(b3)), Trim(b3)) = 0 And Val(Len(qdhz0(Trim(a3)))) = Val(Len(b3)) Then
a1 = 1 & String(Len(a3) - Len(qdhz0(Trim(a3))), "0")
Else
a = a & String(2, "0"): B = B & String(2 + Len(a3), "0")
x = qdqd0(ydxsd(Trim(x), Val(sb)))
Y1 = 2 & String(Val(sb), "0")
Do While MBJC(MPC(Trim(x), Trim(x3)), 1) >= 0
s3 = s3 + 1
Y = mbc2(Trim(x), MPC(Trim(Y1), mbc2(Trim(B), Trim(x), Val(sb))), Val(sb))
x3 = x
x = Trim(Y)
Loop
a1 = mbc2(Trim(Y), Trim(a), Val(sb))
s = Len(a3) - Len(b3)
a1 = qdqd0(Trim(a1))
If MBJC(Mid(a3, 1, Len(b3)), Trim(b3)) < 0 Then
a1 = tjxsd(Trim(a1), Len(a1) - s)
Else
a1 = tjxsd(Trim(a1), Len(a1) - s - 1)
End If
End If
If InStr(a1, ".") = 0 Then
a1 = a1
Else
a1 = Left(a1, InStr(a1, ".") - 1)
End If
ja = MPC(Trim(a3), MbC(Trim(b3), Trim(a1)))
Do While MBJC(Trim(ja), Trim(b3)) >= 0
ja = MPC(Trim(ja), Trim(b3))
s5 = s5 + 1
Loop
a1 = MPC1(Trim(a1), Trim(s5))
If ja = 0 Then
Text3 = a1 & "用时" & Timer - ts & "秒，有" & Len(a1) & "位"
Else
Text3 = a1 & "/" & ja & "用时" & Timer - ts & "秒，整数部分有" & Len(a1) & "位"
End If
End Sub
Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
End Sub
Private Function mbc2(sa As String, sb As String, sd As String) As String 'chengfa jingdu
Dim ja
If Trim(sa) = 0 Or Trim(sb) = 0 Then
mbc2 = 0
Else
ja = MbC(Trim(sa), Trim(sb))
If Val(Len(ja)) > Val(sd) Then
jb = Left(ja, Val(Len(ja)) - Val(sd))
mbc2 = jb
Else
mbc2 = 0
End If
End If
End Function
Private Function qdhz0(sa As String) As String
a = sa
Do While Right(a, 1) = "0"
a = Left(a, Len(a) - 1)
Loop
If a = "" Then
a = 0
Else
a = a
End If
qdhz0 = a
End Function
Private Function qdqd0(sa As String) As String
a = sa
Do While Left(a, 1) = "0"
a = Mid(a, 2)
Loop
If a = "" Then
a = 0
Else
a = a
End If
qdqd0 = a
End Function
Private Function tjxsd(sa As String, sd As String) As String
If Val(Len(sa)) > Val(sd) Then
tjxsd = Left(sa, Val(Len(sa)) - Val(sd)) & "." & Mid(sa, Val(Len(sa)) - Val(sd) + 1)
Else
If Val(Len(sa)) = Val(sd) Then
tjxsd = "0." & sa
Else
tjxsd = "0." & String(Val(sd) - Val(Len(sa)), "0") & Trim(sa)
End If
End If
End Function
Private Function ydxsd(sa As String, sd As String) As String
If Len(sa) = 1 And Val(sa) = 0 Then
ydxsd = 0
Else
sc = InStr(sa, ".")
If Val(sc) = 0 Then
ydxsd = sa & String(sd, "0")
Else
se = Left(sa, Val(sc) - 1)
sf = Right(sa, Len(sa) - Val(sc))
If Val(Len(sf)) >= Val(sd) Then
ydxsd = se & Mid(sf, 1, sd)
Else
ydxsd = se & sf & String(Val(sd) - Len(sf), "0")
End If
End If
End If
End Function
Public Function MbC(D1 As String, D2 As String) As String
Dim j1&, j2&, e&, d&, E1&, m, n
' 按列法计算C=A*B
m = Trim(D1): n = Trim(D2)
x = Len(m) \ 4: Y = Len(n) \ 4
m = String(4 * x + 4 - Len(m), "0") & m
n = String(4 * Y + 4 - Len(n), "0") & n
x = x + 1: Y = Y + 1
Dim a(), B()
ReDim a(1 To x): ReDim B(1 To Y)
For i1 = 1 To x
a(i1) = Val(Mid(m, i1 * 4 - 3, 4))
Next
For i2 = 1 To Y
B(i2) = Val(Mid(n, i2 * 4 - 3, 4))
Next
ma = x: mb = Y
MC = ma + mb
ReDim c(MC)
E1 = 0
j1 = ma: j2 = ma
For I = MC To 2 Step -1
If I <= ma Then j2 = I - 1
e = E1: E1 = 0
For J = j1 To j2
e = e + a(J) * B(I - J)
If e > 2040000000 Then '减少进位次数
e = e - 2040000000
E1 = E1 + 204000
End If
Next J
If j1 > 1 Then j1 = j1 - 1
base = 10000
d = e \ base
c(I) = e - d * base
If Len(c(I)) < 4 Then
c(I) = String(4 - Len(c(I)), "0") & c(I)
Else
c(I) = c(I)
End If
jc = c(I) & jc
E1 = E1 + d
Next I
jc = d & jc
MbC = qdqd0(Trim(jc))
End Function
Public Function MPC(D1 As String, D2 As String) As String ';jianfaqi
Dim x, Y ';两数长度
If qdqd0(D2) = "0" Then
MPC = D1
Else
If Len(D1) >= Len(D2) Then
d4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
d4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
x = Len(d3) \ 8: Y = Len(d4) \ 8
d3 = String(8 * x + 8 - Len(d3), "0") & d3
d4 = String(8 * Y + 8 - Len(d4), "0") & d4
x = x + 1: Y = Y + 1
Dim a() As String, B1() As String, C1() As String, E1() As String
ReDim a(1 To x)
ReDim B1(1 To Y)
ReDim C1(1 To x)
ReDim E1(1 To x)
Dim I, J, C2, CJ, jw
For J = Y To 1 Step -1 ';D2
jw = 1 ';yu jie weichuzhi
B1(J) = Mid(d4, J * 8 - 7, 8) ';每位数
For I = x To 1 Step -1 ';D1
a(I) = Mid(d3, I * 8 - 7, 8) ';每位数
C1(I) = Val(1 & a(I)) - Val(B1(I)) - Val(1) + Val(jw) ';计算jia
If Len(C1(I)) <= 8 Then
jw = 0
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
jw = Left(C1(I), Len(C1(I)) - 8)
End If
E1(I) = Right(C1(I), 8)
If Len(E1(I)) < 8 Then
E1(I) = String(8 - Len(E1(I)), "0") & E1(I)
Else
E1(I) = E1(I)
End If
Next
Next
For r = 1 To x
MPC = MPC & E1(r)
If Len(MPC) > Len(D1) Then
MPC = Mid(MPC, Len(MPC) - Len(D1) + 1)
Else
MPC = MPC
End If
For I = 1 To Len(MPC)
If Not Mid(MPC, I, 1) = "0" Then
Exit For
End If
Next
strTmp = Mid(MPC, I)
If Len(strTmp) = 0 Then
MPC = "0"
Else
MPC = strTmp
End If
Next
End If
End Function
Public Function MPC1(D1 As String, D2 As String) As String 'jiafa
Dim x, Y, jw '两数长度
If qdqd0(D1) = "0" Then
MPC1 = D2
ElseIf qdqd0(D2) = "0" Then
MPC1 = D1
Else
If Len(D1) >= Len(D2) Then
d4 = String(Len(D1) - Len(D2), "0") & D2
d3 = D1
Else
d4 = D2
d3 = String(Len(D2) - Len(D1), "0") & D1
End If
x = Len(d3) \ 8: Y = Len(d4) \ 8
If 8 * x < Len(d3) Then
d3 = String(8 * x + 8 - Len(d3), "0") & d3
d4 = String(8 * Y + 8 - Len(d4), "0") & d4
x = x + 1: Y = Y + 1
Else
x = x: Y = Y
d3 = d3: d4 = d4
End If
Dim a() As String, B1() As String, C1() As String, E1() As String
ReDim a(1 To x)
ReDim B1(1 To Y)
ReDim C1(1 To x)
ReDim E1(1 To x)
Dim I, J, C2, CJ
For J = Y To 1 Step -1 'D2
jw = 0 '进位清0
B1(J) = Mid$(d4, J * 8 - 7, 8) '每位数
For I = x To 1 Step -1 'D1
a(I) = Mid$(d3, I * 8 - 7, 8) '每位数
C1(I) = Val(a(I)) + Val(B1(I)) + Val(jw) '计算jia
If Len(C1(I)) < 8 Then
C1(I) = String(8 - Len(C1(I)), "0") & C1(I)
Else
C1(I) = C1(I)
End If
jw = Left(C1(I), Len(C1(I)) - 8)
E1(I) = Right(C1(I), 8)
Next
Next
For r = 1 To x
If jw = 0 Then
MPC1 = MPC1 & E1(r)
Else
jc = jc & E1(r)
MPC1 = jw & jc
End If
Next
MPC1 = qdqd0(Trim(MPC1))
End If
End Function
Public Function MBJC(D1 As String, D2 As String) As String ';bijiao
If Len(D1) <= 10 And Len(D2) <= 10 Then
If Val(D1) > Val(D2) Then
MBJC = 1
Else
If Val(D1) = Val(D2) Then
MBJC = 0
Else
MBJC = -1
End If
End If
Else
If Len(D1) > Len(D2) Then
MBJC = 1
Else
If Len(D1) < Len(D2) Then
MBJC = -1
Else
If Len(D1) = Len(D2) Then
Dim x, Y
x = Len(D1) \ 4: Y = Len(D2) \ 4
Dim a() As String, B() As String
ReDim a(4 To 4 * x + 4)
ReDim B(4 To 4 * Y + 4)
If Val(Left(D1, Len(D1) - 4 * x)) > Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = 1
Else
If Val(Left(D1, Len(D1) - 4 * x)) < Val(Left(D2, Len(D2) - 4 * Y)) Then
MBJC = -1
Else
For I = 4 To 4 * x Step 4
a(I) = Mid(D1, Len(D1) - I + 1, 4)
B(I) = Mid(D2, Len(D2) - I + 1, 4)
Next
J = 4 * x
Do While a(J) = B(J) And J >= 8
J = J - 4
Loop
If Val(a(J)) - Val(B(J)) > 0 Then
MBJC = 1
Else
If Val(a(J)) - Val(B(J)) < 0 Then
MBJC = -1
Else
MBJC = 0
End If
End If
End If
End If
End If
End If
End If
End If
End Function
（程序稍有改进，就是被除数和除数末尾都少补了8个0，速度稍有提高）
[此贴子已经被作者于2021-4-30 21:45编辑过]
