Office中国论坛/Access中国论坛

标题: 【Access小品】定量不重复随机抽选 [打印本页]

作者: todaynew 时间: 2009-12-31 20:34
标题: 【Access小品】定量不重复随机抽选
本帖最后由 todaynew 于 2010-1-1 09:41 编辑

这是一个基于石三少同志的一个问题编写的实例。问题本身有一定的普遍意义，也就是解决循环随机定量抽检问题。这个问题本身隐含着一个容易导致思维模糊的算法，即：是定率还是定量？

随机从一批货物或者设备中按照一定比例不重复循环抽检，初看起来应该是一个定率抽检问题。其实不然，这实际是一个定量抽检问题。也就是说由于“不重复的存在”，就导致每次抽检不能按照固定的比例进行，而需要按照第一次算出的固定数量进行。

[attach]41054[/attach]

[attach]41055[/attach]

Private Sub 随机抽样(抽样比例 As Single)
Dim rs0 As New ADODB.Recordset
Dim ssql0 As String
Dim rs1 As New ADODB.Recordset
Dim ssql1 As String
Dim i As Long, j As Long
Dim MyValue As Long
Dim str As String
Dim M(1 To 3) As Long
ssql0 = "SELECT 部门 FROM 基础表 GROUP BY 部门;"
rs0.Open ssql0, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
For i = 1 To rs0.RecordCount
M(i) = Int(DCount("*", "基础表", "部门='" & rs0("部门").Value & "'") * 抽样比例)
rs0.MoveNext
Next
rs0.MoveFirst
For i = 1 To rs0.RecordCount
str = "部门='" & rs0("部门").Value & "' and 次=0"
For j = 1 To M(i)
      ssql1 = "select * from 基础表 where " & str
      rs1.Open ssql1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
      MyValue = Int(rs1.RecordCount * Rnd + 1)
      If Not (rs1.EOF Or rs1.BOF) Then
         rs1.Move MyValue - 1
         rs1("次") = Me.次.Value + 1
         rs1.Update
      End If
      rs1.Close
Next
rs0.MoveNext
Next
Me.子窗体.Form.Requery
Me.次.Requery
Me.次.Value = Me.次.ListCount - 1
End Sub

作者: chaojianan 时间: 2009-12-31 21:01
谢谢todaynew代码收藏了。
支持。

作者: ui 时间: 2009-12-31 23:44
最好老兄精品不断!!

作者: ycxchen 时间: 2010-1-1 09:47
最好老兄精品不断,真的！

作者: koutx 时间: 2010-1-1 11:22
新年好，学习了

作者: todaynew 时间: 2010-1-1 17:21
谢谢同志们鼓励，并祝节日愉快！

作者: goto2008 时间: 2010-1-1 23:28
留个脚印。。。谢谢分享

作者: 5988143 时间: 2010-1-4 08:42
祝节日愉快

作者: yanwei82123300 时间: 2010-1-4 09:06
谢谢todaynew代码收藏了。

作者: dragonszr 时间: 2010-1-5 22:04
todaynew,一定要收藏!

作者: cclxf 时间: 2010-1-18 11:19
谢谢分享

作者: greatcf 时间: 2010-1-18 11:25
感谢了

作者: szyewj 时间: 2010-8-22 14:20
很好！很强大！支持精品原創作~

作者: wuweipaopao 时间: 2011-3-16 10:52
谢谢分享！

作者: nncchh 时间: 2015-5-25 22:40
谢谢分享

作者: nncchh 时间: 2015-5-25 22:40
学习下

作者: fjh 时间: 2016-4-26 08:51
已被收藏

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)