VBA代码调试

heftyguy · 发表于 2020-1-8 11:42

本帖最后由 heftyguy 于 2020-1-8 13:30 编辑

无重复抽样代码报错，欢迎大家指正。
Sub sample()

Dim pl As Integer
Dim yb As Integer
Dim p As Integer
Dim i As Integer
Dim j As Integer
Dim N As Integer
pl = InputBox("批量", "输入")
p = InputBox("比例(%)", "抽样")
yb = pl * p / 100
yb = Round(yb, 0)

'输入产品编号及随机数
N = 2: i = 1
Do

Sheet1.Cells(N, 1) = i
Sheet1.Cells(N, 2) = Rnd
N = N + 1: i = i + 1

Loop Until i > pl 'MsgBox (Range("B" & CStr(N)))

'同名排序及不同名排序
N = N - 1
M = 2: i = 1
Do

Sheet1.Cells(M, 3) = WorksheetFunction.Rank(Sheet1.Cells(M, 2), Range("B2", "B" & CStr(N)), 1) '同名次序
Sheet1.Cells(M, 4) = WorksheetFunction.Rank(Sheet1.Cells(M, 2), Range("B2", "B" & CStr(N)), 1) + WorksheetFunction.CountIf(Range("B2", "B" & CStr(M)), "B" & CStr(M)) - 1 '不同名次序，但似乎countif（）不工作

M = M + 1

Loop Until i > pl

'按照不同名次序结果升序，但没有运行
ActiveWorkbook.Worksheets("sample").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("sample").Sort.SortFields.Add2 Key:=Range("D2", "D" & CStr(N)) _
      , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("sample").Sort
      .SetRange Range("A1", "D" & CStr(N))
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
End With

'输出抽样结果
j = 1: M = 2
Do

Sheet1.Cells(M, 7) = Sheet1.Cells(M, 1)
Sheet1.Cells(M, 8) = Sheet1.Cells(M, 4)
M = M + 1: j = j + 1

Loop Until j > yb

End Sub

heftyguy · 发表于 2020-1-8 11:47

比如：样本量50，抽样比例20%，抽取10个

hfwufanhf2006 · 发表于 2020-1-8 11:53

没有文件调试不了，也看不懂你说的抽样具体是什么意思。
抽样五花八门！

heftyguy · 发表于 2020-1-8 12:02

文件界面就是上传的图片，Sheet1,

heftyguy · 发表于 2020-1-8 13:32

hfwufanhf2006 发表于 2020-1-8 11:53
没有文件调试不了，也看不懂你说的抽样具体是什么意思。
抽样五花八门！

传EXCEL提示不能上传，压缩包上传可以了。

hfwufanhf2006 · 发表于 2020-1-8 14:46

heftyguy 发表于 2020-1-8 13:32
传EXCEL提示不能上传，压缩包上传可以了。

你这个代码在工作表函数那里就不对了，提示“不能获取rank属性”。我对工作表函数不熟，平时也不怎么用，没办法确定是什问题；我测试了，如果把工作表函数的两行代码注释掉，程序就进入了死机状态，无法确认是死循环还是其他问题，显示“excel未响应”，只能强制中断；
所以我觉得你这个代码不能用。

heftyguy · 发表于 2020-1-8 14:53

可以运行的，

hfwufanhf2006 · 发表于 2020-1-8 15:16

heftyguy 发表于 2020-1-8 14:53
可以运行的，

可能是版本差异，我是2016版。如果是版本差异，我还是认为这个代码不可靠。不管怎么说，不能因为版本就出现死机的状态。既然是使用了工作表函数，可以把使用工作表函数的那部分手工来操作；
其他的地方，因为我电脑上不能运行，无法观察哪里有问题，我试过多次了，都是死机；

大灰狼1976 · 发表于 2020-1-8 15:29

尽量保持原貌修改。

Sub sample()
Dim pl As Integer
Dim yb As Integer
Dim p As Integer
Dim i As Integer
Dim j As Integer
Dim N As Integer
pl = InputBox("sample", "enter")
p = InputBox("%", "sample")
yb = pl * p / 100
yb = Round(yb, 0)
Randomize
N = 2: i = 1
Do
Sheet1.Cells(N, 1) = i
Sheet1.Cells(N, 2) = Rnd
N = N + 1: i = i + 1
Loop Until i > pl
N = N - 1
m = 2: i = 1
Do
Sheet1.Cells(m, 3) = WorksheetFunction.Rank(Sheet1.Cells(m, 2), Range("B2", "B" & CStr(N)), 1)
Sheet1.Cells(m, 4) = WorksheetFunction.Rank(Sheet1.Cells(m, 2), Range("B2", "B" & CStr(N)), 1) + WorksheetFunction.CountIf(Range("B2", "B" & CStr(m) - 1), Range("B" & CStr(m)))
m = m + 1
Loop Until m > pl + 1
Sheet1.Range("a2:d" & pl + 1).Sort [d2]
j = 1: m = 2
Do
Sheet1.Cells(m, 7) = Sheet1.Cells(m, 1)
Sheet1.Cells(m, 8) = Sheet1.Cells(m, 4)
m = m + 1: j = j + 1
Loop Until j > yb
End Sub

复制代码

heftyguy · 发表于 2020-1-8 15:45

大灰狼1976 发表于 2020-1-8 15:29
尽量保持原貌修改。

代码保持了原貌，测试通过，强！

		自动登录	找回密码
密码			注册