根据类别从列表中随机选择一个项目,根据不同的数字重复次数

时间:2015-05-29 11:48:55

标签: excel vba excel-vba

我不熟悉使用宏,但我认为我最擅长表现的是用宏来处理。所以我可以使用你可能拥有的所有输入!

我有这些标题;

ID标签笔性别重量等级内部范围

拥有450行数据。根据权重数据的分布,我在其他两列(类和数字)中有我想在每个类中选择的行数。所选行的“内部范围”列中的值必须为“是”。

我想根据每个类所需的数量随机选择行,并将这些行复制到新工作表中。它在新表中总计最多30行。

我希望你有一个建议如何完成这个动作!

1 个答案:

答案 0 :(得分:0)

can you try the following, you will need to add a reference to Microsoft Scripting Runtime library:

Const rowCount = 450
Public Sub copyRows() 
    Dim i As Integer
    Dim j As Integer 
    Dim classes As Scripting.Dictionary
    Dim source As Worksheet
    Dim colNumber As Integer
    Dim colClassName as Integer
    Dim colInsideRange As Integer
    Dim allSelected As Boolean
    Dim randomRow as Integer
    Dim sumRemaining as Integer
    allSelected = False
    Set source = Worksheets("YourWorksheetName")
    colClassName = 6 'this is the column number where class names are entered. I am assuming 6
    colNumber = 7 'this is the column number where number of rows to be selected are entered. I am assuming 7
    colInsideRange  = 8 'this is the column number where "Inside Range" values are entered. I am assuming 9
    For i = 2 to rowCount + 1 'assuming you have a header row
        classes(CStr(source.Cells(i, colClassName))) = CInt(source.cells(i, colNumber)
    Next i
    Do until allSelected 
        Randomize
        randomRow = Int ((Rnd * 450) + 2) 'assuming you have a header row, + 1 if you don't
        If classes(CStr(source.Cells(randomRow, colClassName))) = 0 Then
            With classes
                sumRemaining = 0
                For j = 1 to .Count - 1
                    sumRemaining = sumRemaining + .Items(j)
                    If sumRemaining > 0 Then Exit For
                Next j
                allSelected = (sumRemaining = 0)
            End With
        Else
            source.Cells(randomRow, colInsideRange) = "Yes"
            classes(CStr(source.Cells(randomRow, colClassName))) = classes(CStr(source.Cells(randomRow, colClassName))) - 1
        End If
    Loop
    'Enter your code to copy rows with "Inside Range" = "Yes"
End Sub

Sorry if there are some errors or typos, I wrote from my mobile phone.