[已解决]VBA位置全部任意

vbyou127

VBA位置全部任意

满足条件的除式共有9369个

最佳答案

月排行榜 / 总排行榜

lichuanboy44

2016-4-26 11:17

1. sub pubu()
   
2. '有思路，不敢运行的程序
   
3. tt = Timer
   
4. Dim cr1: p = 1
   
5. ReDim cr1(1 To 2, 1 To p)
   
6. For a = 100 To 999         '除数为3位数
   
7.   For Z = 10000 To 99999   '商为5位数，且千位必为0
   
8.    s = Z * a               '乘积s为被除数,应为8位数
   
9.    z1 = --Mid(Z, 1, 1): z2 = --Mid(Z, 2, 1): z3 = --Mid(Z, 3, 1)
   
10.    z4 = --Mid(Z, 4, 1): z5 = --Mid(Z, 5, 1)    '将商的各位数依次取出
    
11.    If z2 = 0 Then                           '0if
    
12.      If s >= 10000000 And s <= 99999999 Then    '1if
    
13.      s1 = --Mid(s, 1, 4) - z1 * a   '除法算式第一步：被除数左起4位数-商的万位数*除数
    
14.        If Len(z1 * a) = 4 And s1 >= 10 And s1 <= 99 Then  '2if
    
15.        s2 = s1 * 100 + Val(Mid(s, 5, 2)) - z3 * a '算式第二步：上步差*100+被除数5和6位数-商的百位数*除数
    
16.          If Len(z3 * a) = 3 And s2 >= 10 And s2 <= 99 Then   '3if
    
17.          s3 = s2 * 10 + Val(Mid(s, 7, 1)) - z4 * a  '算式第三步，类同第二步
    
18.            If Len(z4 * a) = 3 And s3 >= 100 And s3 <= 999 Then     '4if
    
19.            s4 = s3 * 10 + Val(Mid(s, 8, 1)) - z5 * a   '算式第四步，同上
    
20.              If Len(z5 * a) = 4 And s4 = 0 Then                       '5if
    
21.                ReDim Preserve cr1(1 To 2, 1 To p)
    
22.                cr1(1, p) = a: cr1(2, p) = Z
    
23.                p = p + 1
    
24.                tt2 = Timer
    
25.                If tt2 - tt > 600 Then
    
26.                  MsgBox "程序运行大于600秒，防止死机退出"
    
27.                  Exit Sub
    
28.                End If
    
29.     End If   '5if
    
30.     End If   '4if
    
31.     End If   '3if
    
32.     End If   '2if
    
33.     End If   '1if
    
34.    End If    '0if
    
35.   Next
    
36. Next
    
37. [G1] = UBound(cr1, 2): [G2] = Timer - tt
    
38. [A1].Resize(p, 2) = WorksheetFunction.Transpose(cr1)
    
39. MsgBox Format(Timer - tt, "0.000秒") & vbCrLf & _
    
40.      "符合条件的数的个数为：" & UBound(cr1, 2)
    
41. 'Stop
    
42. End Sub

复制代码

跳转到最佳答案楼层

lichuanboy44

1. sub pubu()
   
2. '有思路，不敢运行的程序
   
3. tt = Timer
   
4. Dim cr1: p = 1
   
5. ReDim cr1(1 To 2, 1 To p)
   
6. For a = 100 To 999         '除数为3位数
   
7.   For Z = 10000 To 99999   '商为5位数，且千位必为0
   
8.    s = Z * a               '乘积s为被除数,应为8位数
   
9.    z1 = --Mid(Z, 1, 1): z2 = --Mid(Z, 2, 1): z3 = --Mid(Z, 3, 1)
   
10.    z4 = --Mid(Z, 4, 1): z5 = --Mid(Z, 5, 1)    '将商的各位数依次取出
    
11.    If z2 = 0 Then                           '0if
    
12.      If s >= 10000000 And s <= 99999999 Then    '1if
    
13.      s1 = --Mid(s, 1, 4) - z1 * a   '除法算式第一步：被除数左起4位数-商的万位数*除数
    
14.        If Len(z1 * a) = 4 And s1 >= 10 And s1 <= 99 Then  '2if
    
15.        s2 = s1 * 100 + Val(Mid(s, 5, 2)) - z3 * a '算式第二步：上步差*100+被除数5和6位数-商的百位数*除数
    
16.          If Len(z3 * a) = 3 And s2 >= 10 And s2 <= 99 Then   '3if
    
17.          s3 = s2 * 10 + Val(Mid(s, 7, 1)) - z4 * a  '算式第三步，类同第二步
    
18.            If Len(z4 * a) = 3 And s3 >= 100 And s3 <= 999 Then     '4if
    
19.            s4 = s3 * 10 + Val(Mid(s, 8, 1)) - z5 * a   '算式第四步，同上
    
20.              If Len(z5 * a) = 4 And s4 = 0 Then                       '5if
    
21.                ReDim Preserve cr1(1 To 2, 1 To p)
    
22.                cr1(1, p) = a: cr1(2, p) = Z
    
23.                p = p + 1
    
24.                tt2 = Timer
    
25.                If tt2 - tt > 600 Then
    
26.                  MsgBox "程序运行大于600秒，防止死机退出"
    
27.                  Exit Sub
    
28.                End If
    
29.     End If   '5if
    
30.     End If   '4if
    
31.     End If   '3if
    
32.     End If   '2if
    
33.     End If   '1if
    
34.    End If    '0if
    
35.   Next
    
36. Next
    
37. [G1] = UBound(cr1, 2): [G2] = Timer - tt
    
38. [A1].Resize(p, 2) = WorksheetFunction.Transpose(cr1)
    
39. MsgBox Format(Timer - tt, "0.000秒") & vbCrLf & _
    
40.      "符合条件的数的个数为：" & UBound(cr1, 2)
    
41. 'Stop
    
42. End Sub

复制代码

lichuanboy44

经运行以上程序，符合条件的数共有5969个，
其中最小的为10541964/116=90879；最大值为45019281/499=90219
本人电脑上运行耗时324秒。

lichuanboy44

你说满足条件的有9369个，我验证个数为10840个。理由如下：
1、如果左起第一位即千万位不为0的话，则有5969个，其中被除数最小为10360206/114=90879，最大为45019281/499=90219
2、如果左起第一位等于0的话，则有4871个，其中被除数最小为1240206/114=10879，最大为9988433/247=40439
程序分两个独立运算，第一个经改进后需110秒，第二个需92秒。

vbyou127

lichuanboy44 发表于 2016-4-26 16:09
你说满足条件的有9369个，我验证个数为10840个。理由如下：
1、如果左起第一位即千万位不为0的话，则有596 ..

你做得很好了，只是有点卡好慢，看下面

Sub s()
For c = 100 To 999
d1 = 9
e1 = c * d1
Do While e1 > 999
f1 = e1 \ 10
d2 = 1
e2 = c * d2 + f1
Do While e2 < 1000
f2 = e2 \ 10
d3 = 1
e3 = c * d3 + f2
Do While c * d3 < 1000
If e3 > 999 Then
f3 = e3 \ 100
d4 = 9
e4 = c * d4
Do While e4 > 999
If e4 + f3 < 9999 Then
r = r + 1
d = d1 + d2 * 10 + d3 * 100 + d4 * 10000
Cells(r, 1) = c * d
Cells(r, 2) = c
Cells(r, 3) = d
End If
d4 = d4 - 1
e4 = c * d4
Loop
End If
d3 = d3 + 1
e3 = c * d3 + f2
Loop
d2 = d2 + 1
e2 = c * d2 + f1
Loop
d1 = d1 - 1
e1 = c * d1
Loop
Next
End Sub

香川群子

商的第2位一定是=0……哈哈哈。

lichuanboy44

vbyou127 发表于 2016-4-26 16:25
lichuanboy44 发表于 2016-4-26 16:09
你说满足条件的有9369个，我验证个数为10840个。理由如下：
1、如 ...

最佳实在有愧，你的代码效率太高，我正在学习中，谢谢鼓励，我早就关注到你，其实是高手。

香川群子

没这么复杂吧。

我计算也是只有5969个解。

速度飞快：

1. Sub test() 'by kagawa
   
2.     Dim abc&, d&, e&, f&, g&, h&, defgh&, s&, k&, tms#
   
3.     tms = Timer
   
4.     For abc = 100 To 999
   
5.         For d = 1 To 9
   
6.             If abc * d > 1000 Then
   
7.                 For f = 1 To 9
   
8.                     If abc * f < 1000 Then
   
9.                         For g = 1 To 9
   
10.                             If abc * g < 1000 Then
    
11.                                 For h = 1 To 9
    
12.                                     If abc * h > 1000 Then
    
13.                                         defgh = d * 10000 + f * 100 + g * 10 + h
    
14.                                         s = abc * defgh
    
15.                                         If s > 10000000 Then
    
16.                                             s1 = s - abc * d * 10000
    
17.                                             If s1 > 100000 And s1 < 1000000 Then
    
18.                                                 s2 = s - abc * (d * 10000 + f * 100)
    
19.                                                 If s2 > 1000 And s2 < 10000 Then
    
20.                                                     s3 = s - abc * (d * 10000 + f * 100 + g * 10)
    
21.                                                     If s3 > 1000 And s3 < 10000 Then
    
22.                                                         k = k + 1 ': Stop
    
23.                                                     Else
    
24.                                                         Stop
    
25.                                                     End If
    
26.                                                 End If
    
27.                                             End If
    
28.                                         End If
    
29.                                     End If
    
30.                                 Next
    
31.                             End If
    
32.                         Next
    
33.                     End If
    
34.                 Next
    
35.             End If
    
36.         Next
    
37.     Next
    
38.     MsgBox Format(Timer - tms, "0.000s ") & k
    
39. End Sub
    

复制代码

第1组：
114*90879=10360206

香川群子

最后1组：
499*90219=45019281

							9	0	2	1	9
4	9	9	/	4	5	0	1	9	2	8	1
				4	4	9	1
						1	0	9	2
							9	9	8
								9	4	8
								4	9	9
								4	4	9	1
								4	4	9	1

lichuanboy44

香川群子 发表于 2016-4-27 08:17
商的第2位一定是=0……哈哈哈。

       你的帖子我看过很多，很佩服。我的代码问题速度慢自己感觉到水平不高，经过痛苦思考后，突然看到优秀的答案后，眼前闪亮，心情激动的感觉无法形容。
       我的代码缺点主要有：
      一是不应该将商设成一个整数后，然后再用mid 又依次将各位数取出来，这无异于自寻烦恼。要象vbyou127那样，直接将各位数单独设一个变量。即使就像我那样，也尽量少用mid，因原来看过相关贴子，mid等字符操作函数速度较慢，在数据量大时，真的体现出来了。此处我用int替换后，原来需要324秒，int需要110秒.
      二是将for和if改为loop循环，如果7*a小于999，那么就不需要再用6来试了，减少废循环。这个我有时间在调试，估计也提速。
     三是只需考虑商与除数的乘积是三位数还是四位数，我按竖式结构，还考虑竖式计算中每一步的差是两位还是三位数，以为多个条件，能提高处理效率，但反而使判定处理更加复杂化了。
     四是不该用len来测定数据的位数，如果判定3位数，用 s>=100 and <=999,再一次体现字符处理函数len效率较低，能不用尽量不用。