布丰投针实验之VBA模拟——问题：29楼，解答：33楼

aoe1981

　　（置顶出题：http://club.excelhome.net/forum. ... 1170228&pid=7978993）

　　（初步解答：http://club.excelhome.net/forum. ... 1170228&pid=7979201）

　　（重要数据：http://club.excelhome.net/forum. ... 1170228&pid=7979320）



　　发此帖的来由：
　　

　　

　　发此帖的经过：
　　

　　

　　本帖附件如下：
　　 布丰投针实验之VBA模拟（aoe1981）.rar (338.06 KB, 下载次数: 69)

2014-12-3 22:11 上传

点击文件名下载附件

　　（6楼关于榜单排序标题丢失的问题已纠正）
　　（7楼关于单元格B16公式在个别情况下除数为0的问题已纠正）
　　（随机投针次数数据有效性增加值：3000，便于冲刺1901年投针世界纪录）
　　附件截图如下：
　　


　　下面是一个2003版：
　　 布丰投针实验之VBA模拟2003版（aoe1981）.rar (73.43 KB, 下载次数: 61)

2014-12-4 19:18 上传

点击文件名下载附件

aoe1981

所有代码如下，查看行数：

1. Option Explicit
   
2. Dim XY_max%, a%, L_count%, pd1%, pd2%
   
3. Public Sub PingXingXian() '生成平行线
   
4.     With aoe
   
5.         .Range("d2:e" & Rows.Count) = ""
   
6.         .Range("g2:h" & Rows.Count) = ""
   
7.         If .Range("b1") = "" Or .Range("b2") = "" Or Not (IsNumeric(.Range("b1"))) _
   
8.         Or Not (IsNumeric(.Range("b2"))) Then MsgBox "请输入正确的坐标最大值和平行线距离！", , "友情提示": Exit Sub
   
9.         Dim i%, j%
   
10.         XY_max = .Range("b1").Value
    
11.         a = .Range("b2").Value
    
12.         L_count = Int((XY_max * 2) / a) + 1
    
13.         ReDim zb_l(1 To L_count * 3, 1 To 2)
    
14.         j = 1
    
15.         For i = 1 To L_count * 3
    
16.             If i Mod 3 Then
    
17.                 zb_l(i, 1) = XY_max * j
    
18.                 If j = 1 Then j = -1 Else j = 1
    
19.                 zb_l(i, 2) = XY_max - Int(i / 3) * a
    
20.             End If
    
21.         Next i
    
22.         .Range("d2").Resize(L_count * 3, 2) = zb_l
    
23.         pd1 = 1: pd2 = 1
    
24.     End With
    
25. End Sub
    
26. Public Sub TuBiao() '规范图表
    
27.     If pd1 = 0 Then MsgBox "请点击生成平行线！", , "友情提示": Exit Sub
    
28.     Application.ScreenUpdating = False
    
29.     With aoe
    
30.         .Unprotect Password:="123"
    
31.         .ChartObjects("图表 1").Activate
    
32.         With ActiveChart 'Y轴
    
33.             .HasAxis(xlValue, xlPrimary) = True
    
34.             .Axes(xlValue).MinimumScale = -aoe.Range("b1").Value - aoe.Range("b2").Value
    
35.             .Axes(xlValue).MaximumScale = aoe.Range("b1").Value + aoe.Range("b2").Value
    
36.             .Axes(xlValue).MinorUnit = aoe.Range("b2").Value
    
37.             .Axes(xlValue).MajorUnit = aoe.Range("b2").Value
    
38.             .HasAxis(xlValue, xlPrimary) = False
    
39.         End With
    
40.         With ActiveChart 'X轴
    
41.             .HasAxis(xlCategory, xlPrimary) = True
    
42.             .Axes(xlCategory).MinimumScale = -aoe.Range("b1").Value - aoe.Range("b2").Value
    
43.             .Axes(xlCategory).MaximumScale = aoe.Range("b1").Value + aoe.Range("b2").Value
    
44.             .Axes(xlCategory).MinorUnit = aoe.Range("b2").Value
    
45.             .Axes(xlCategory).MajorUnit = aoe.Range("b2").Value
    
46.             .HasAxis(xlCategory, xlPrimary) = False
    
47.         End With
    
48.         .Range("b12").Select
    
49.         .Protect Password:="123"
    
50.     End With
    
51.     Application.ScreenUpdating = True
    
52.     pd1 = 0: pd2 = 2
    
53. End Sub
    
54. Public Sub TouZhen() '随机投针
    
55.     If pd2 = 1 Then MsgBox "请点击规范图表！", , "友情提示": Exit Sub
    
56.     If pd2 <> 2 Then MsgBox "请点击生成平行线！", , "友情提示": Exit Sub
    
57.     With aoe
    
58.         .Range("g2:h" & Rows.Count) = ""
    
59.         .Range("b13") = ""
    
60.         If .Range("b11") = "" Or .Range("b12") = "" Or Not (IsNumeric(.Range("b11"))) _
    
61.         Or Not (IsNumeric(.Range("b12"))) Then MsgBox "请输入正确的针的长度和随机投针次数！", , "友情提示": Exit Sub
    
62.         Dim X1#, Y1#, X2#, Y2#, L%, jd#, R_count&, i&, j&, gd#, cs&, rng As Range
    
63.         Randomize
    
64.         cs = 0
    
65.         L = .Range("b11").Value
    
66.         R_count = .Range("b12").Value
    
67.         ReDim zb_n(1 To R_count * 3, 1 To 2)
    
68.         ReDim Y_count%(1 To L_count)
    
69.         For i = 1 To L_count
    
70.             Y_count(i) = XY_max - a * (i - 1)
    
71.         Next i
    
72.         For i = 1 To R_count
    
73.             X1 = Rnd() * XY_max * IIf(Rnd() < 0.5, 1, -1)
    
74.             Y1 = Rnd() * XY_max * IIf(Rnd() < 0.5, 1, -1)
    
75.             jd = Rnd() * 360
    
76.             X2 = X1 + L * Sin(jd / 180 * WorksheetFunction.Pi())
    
77.             Y2 = Y1 + L * Cos(jd / 180 * WorksheetFunction.Pi())
    
78.             zb_n((i - 1) * 3 + 1, 1) = X1: zb_n((i - 1) * 3 + 1, 2) = Y1
    
79.             zb_n((i - 1) * 3 + 2, 1) = X2: zb_n((i - 1) * 3 + 2, 2) = Y2
    
80.             If Y1 > Y2 Then gd = Y1: Y1 = Y2: Y2 = gd
    
81.             For j = 1 To L_count
    
82.                 If Y_count(j) >= Y1 And Y_count(j) <= Y2 Then cs = cs + 1: Exit For
    
83.             Next j
    
84.         Next i
    
85.         Application.ScreenUpdating = False
    
86.         .Range("g2").Resize(R_count * 3, 2) = zb_n
    
87.         .Range("b13").Value = cs
    
88.         Set rng = .Range("ab" & Rows.Count).End(xlUp).Offset(1)
    
89.         If rng.Row() < 12 Then
    
90.             rng.Value = "'" & Format(Now(), "yyyy-mm-dd hh:mm:ss"): rng.Offset(, 1) = R_count
    
91.             rng.Offset(, 2) = .Range("b16").Value: rng.Offset(, 3) = .Range("b18").Value
    
92.             rng.Offset(, 4) = Abs(.Range("b18").Value)
    
93.         Else
    
94.             Range("ab12").Value = "'" & Format(Now(), "yyyy-mm-dd hh:mm:ss"): Range("ac12").Value = R_count
    
95.             Range("ad12").Value = .Range("b16").Value: Range("ae12").Value = .Range("b18").Value
    
96.             Range("af12").Value = Abs(.Range("b18").Value)
    
97.             With .Sort
    
98.                 .SortFields.Clear
    
99.                 .SortFields.Add Key:=Range("AF2:AF12"), Order:=xlAscending
    
100.                 .SortFields.Add Key:=Range("AC2:AC12"), Order:=xlAscending
     
101.                 .SetRange Range("AB1:AF12")
     
102.                 .Header = xlYes
     
103.                 .Apply
     
104.             End With
     
105.         End If
     
106.         .Range("b12").Select
     
107.         Application.ScreenUpdating = True
     
108.     End With
     
109. End Sub
     
110. Public Sub LiShiJiLu() '历史记录
     
111. Dim XinX(), BaoG$, i%
     
112. XinX = aoe.Range("AA1:AE11").Value
     
113. BaoG = Right(" " & XinX(1, 1), 2) & "　　　　" & XinX(1, 2) & "　　　　" _
     
114. & XinX(1, 3) & "　　　 　" & XinX(1, 4) & "　　　" & XinX(1, 5)
     
115. For i = 2 To 11
     
116.     BaoG = BaoG & Chr(10) & Right(" " & XinX(i, 1), 2) & "   " & XinX(i, 2) _
     
117.     & "   " & Right("     " & XinX(i, 3), 5) & "   " & Right("                " & XinX(i, 4), 16) & _
     
118.     "   " & Right(" " & Format(XinX(i, 5), "0.0000"), 7)
     
119. Next i
     
120. MsgBox BaoG, , "布丰投针实验π值逼近历史记录TOP10"
     
121. End Sub
     

复制代码

1. 
   

复制代码

aoe1981

最后的排序生成历史记录榜单的部分代码没有在2003中得到充分测试，希望可以正常运行，我主要是在2010中编辑的2003格式文件，主体部分在2003中测试过的，并加了一些对于2010来说可能是多余，但在2003中又是十分必要的代码，比如：散点图坐标轴显示与隐藏的语句。

aoe1981

关于“随机投针次数”，我在一开始的设计中，其数据有效性最大值是20000，由于1根针的数据要占3行，这对于65536行而言，是个整万的极值，故而如此设置。

但在2003中测试20000次的时候出错，原因是：散点图最多容纳32000个数据点，这个20000＊3时便超过了，因而改成了最大值10000。

又但是，在2010中，散点图最大可容纳的数据点似乎大大增加了，受限于65536的制约，没有测试出来……

特此标记一下。

aoe1981

　　以下是“布丰投针实验π值逼近历史记录TOP10”的榜单截图：
　　

　　对齐的应该还是很工整的，呵呵。

aoe1981

发现一个错误：
排序部分语句应当加入下面一句：

1.                 .Header = xlYes
   

复制代码

否则，标题就不见了……呵呵

aoe1981

还真是不好意思，又发现了一个极端情况下，单元格公式除数为0时出错的情况：


可见，就是投针相交次数为0的特殊情况下的错误。

解决方法如下：
修改单元格B16公式如下：

B16=2*B11/(B14*B2)

B16=IF(B14,2*B11/(B14*B2),0)

aoe1981

　　以下数据来自百度百科：《蒲丰投针问题》
　　http://baike.baidu.com/item/%E8% ... A%8C&fr=aladdin

试验者	时间	投掷次数	相交次数	圆周率估计值
Wolf	1850年	5000	2532	3.1596
Smith	1855年	3204	1218.5	3.1554
C.De Morgan	1860年	600	382.5	3.137
Fox	1884年	1030	489	3.1595
Lazzerini	1901年	3408	1808	3.1415929
Reina	1925年	2520	859	3.1795

我使用了以下公式，将粘贴后的一列数据转为表格：

1. =INDEX($A$1:$A$35,(ROW()-1)*5+COLUMN(A1))

复制代码

aoe1981

显然，记录保持者是：

						精确π值=PI()	误差率=(E2-G2)/G2
Lazzerini	1901年	3408	1808	3.1415929		3.141592654	0.00000784348049146213%

不知道用VBA，是否有人可以幸运的超越这一极限？

遐想中……

Curry_Chen

@aoe1981,太厉害！！！