以下是引用hulu456123在2007-12-2 2:26:56的发言:精确到小数点后两位可以吗? 总是死机………… Private arr(1 To 200), arr1, j, z, k, bb Private arr3(1 To 65536, 1 To 1) Sub cai() Application.ScreenUpdating = False aa = Timer Columns("A:A").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin Range("C:i") = "" z = [A65536].End(xlUp).Row arr1 = Range("a1", Cells(z, 1)) For i = z To 1 Step -1 arr(i) = arr(i + 1) + arr1(i, 1) Next i j = 0 k = Cells(1, 2) bb = 0 lj 1, k, "" Range(Cells(1, 3 + bb), Cells(j, 3 + bb)) = arr3 MsgBox "找到 " & bb * 65536 + j & " 个解! 花费" & Format(Timer - aa, "0.00") & "秒" End Sub Sub lj(i, x, y$) If x >= arr1(i, 1) And x <= arr(i) Then If x = arr1(i, 1) Then If j = 65536 Then Range(Cells(1, 3 + bb), Cells(j, 3 + bb)) = arr3 j = 1 bb = bb + 1 Else j = j + 1 End If arr3(j, 1) = y & arr1(i, 1) & "=" & k Else If i < z Then If x >= 2 * arr1(i, 1) Then lj i + 1, x - arr1(i, 1), y & arr1(i, 1) & "+" lj i + 1, x, y End If End If End If End Sub 这样就可以了 |