Dim numlen As Long, last As Long, x As Long
Dim i As Long, m As Long, n As Long, nl As Long, s0 As String
Dim result() As Long, starttime As Single, s() As String
numlen = 1
starttime = Timer
ReDim result(1 To numlen)
nl = 9 - Len(CStr(num)) '根據兩數相乘最大得數長度，不會超過兩數長度總和的原理，
'讓數組中每個元素長度與階乘數長度之和不能超過9，以防止溢出。
If nl < 1 Then nl = 1 '最小長度是1位，若真到了這麽大的數，恐怕沒人會去試了^-^
n = 10 ^ nl '緩存用於分隔大數的被除數，數組中每個元素的長度是 nl，該數就是10的 nl 次方
result(1) = 1
x = 1
Do While x <= num
last = 0
For i = 1 To numlen
m = result(i) * x + last '數組中每個元素進行與待乘數相乘後，再加上上次進位數
result(i) = m Mod n '分隔大數
last = m \ n '保存進位數並等待累計進下壹個數組元素
Next
If last > 0 Then
m = Len(CStr(last)) \ nl + 1 '對超過數組元素上限的進位數要增加數組大小，並按長度nl分隔
ReDim Preserve result(1 To numlen + m)
For i = 1 To m
result(numlen + i) = last Mod n
last = last \ n
Next
numlen = UBound(result)
End If
x = x + 1
Loop
ReDim s(1 To numlen)
s0 = String(nl, "0") '對長度不足nl的數組元素要在前面補0，不然結果就在錯特錯了
For i = 1 To numlen
s(i) = Format(result(numlen + 1 - i), s0) '格式化補 0 每個數組元素
Next
s(1) = Val(s(1))
If s(1) = 0 Then s(1) = "" '最高位要去掉0，雖對得數沒影響，但位數會錯。
cacl = Join(s, "")
Debug.Print num & "！ ： 用時 "; Timer - starttime & " 秒, 結果 " & Len(cacl) & " 位"
End Function
Private Sub Command1_Click()
Dim i As Long
Dim n As Long
Dim t As Double
n = InputBox("輸入N值")
For i = 1 To Val(n)
t = t + Val(cacl(i))
Next
Print "1!+2!+3!+...+" & n & "!="; t
End Sub
呵呵 改進速度的 10000！只需10秒