vba如何根据多列选择一组行

Question

请帮忙

我正在尝试执行以下操作：

1. 我有一个包含 50000 行的 excel 文件“A”。

2. 我正在创建另一个 150 行的 excel 'B'。

3. 150 行是从文件“A”中挑选出来的。

4. 行选择标准基于 5 个不同列 的值作为此集合

5. 首先我要确保我选择了这 5 列的所有不同组合的行

6. 如果我用完了组合，那么我可以选择重复的组合，因为必须达到 150

7. 到目前为止，我已经实现的是从 excel A 中选择 150 个随机行并粘贴到 excel B

   记录 = 150

    With DataWs
   
        SourceLastRow = .Cells(.Rows.count, "B").End(xlUp).Row
        .Rows(1).Copy DestinationWs.Cells(DestLastRow, "A")
   
        ar = RandomNumber(2, SourceLastRow, Records)
        For r = 2 To UBound(ar)                           
            DestLastRow = DestLastRow + 1
            .Rows(ar(r)).Copy DestinationWs.Cells(DestLastRow, "A")
        Next r
    End With
   
    Function RandomNumber(Bottom As Long, Top As Long, Amount As Long) As Variant
    Dim i As Long, r As Long, temp As Long
   
    ReDim iArr(Bottom To Top) As Long
    For i = Bottom To Top: iArr(i) = i: Next i
    For i = 1 To Amount
        r = Int(Rnd() * (Top - Bottom + 1 - (i - 1))) _
            + (Bottom + (i - 1))
        temp = iArr(r): iArr(r) = iArr(Bottom + i - 1): _
            iArr(Bottom + i - 1) = temp
        Next i
    ReDim Preserve iArr(Bottom To Bottom + Amount - 1)
    RandomNumber = iArr
   

   结束函数

Answer 1

这可能有点复杂，但对我有用：

Sub PickRows()
    Const COPY_ROWS As Long = 150
    Dim dict As Object, data, DataWS As Worksheet, DestWS As Worksheet
    Dim numCopied As Long, r As Long, k As String, destRow As Long
    Dim combo As Long, keys, col As Collection, theRow As Long, t
    
    
    Set DataWS = Sheet2 'for example
    Set DestWS = Sheet3 'for example
    
    'get the source data (at least the part with the key columns) in an array
    data = DataWS.Range("A1:E" & DataWS.Cells(DataWS.Rows.Count, "B").End(xlUp).Row).Value
    Set dict = CreateObject("scripting.dictionary")
    
    'fill the dictionary - keys are combined 5 columns, values are collection
    '  containing the row number for each source row with that key
    For r = 2 To UBound(data, 1)
        k = RowKey(data, r, Array(1, 2, 3, 4, 5)) 'combination of the 5 columns
        If Not dict.exists(k) Then
            dict.Add k, New Collection 'new combination?
        End If
       dict(k).Add r
    Next r
    
    numCopied = 0
    combo = 0
    destRow = 2
    
    'loop over the various key column combinations and pick a row from each
    '   keep looping until we've copied enough rows
    Do While numCopied < COPY_ROWS
        'see here for why the extra ()
        'https://stackoverflow.com/questions/26585884/runtime-error-with-dictionary-when-using-late-binding-but-not-early-binding
        Set col = dict.Items()(combo) 'a collection of all rows for this particular key
        theRow = RemoveRandom(col)
        'edit line below to copy more columns (eg change 5 to 10)
        DataWS.Cells(theRow, 1).Resize(1, 5).Copy DestWS.Cells(destRow, 1)
        destRow = destRow + 1 'next destination row
        
        If col.Count = 0 Then dict.Remove dict.keys()(combo) 'remove if no more rows for this key
        If dict.Count = 0 Then Exit Do 'run out of any rows to pick? (should not happen...)
        
        combo = combo + 1
        If combo >= dict.Count Then combo = 0 'start looping again
        numCopied = numCopied + 1
    Loop

End Sub

'Create a composite key from columns in arrKeyCols
Function RowKey(data, rowNum, arrKeyCols) As String
    Dim rv, i, sep
    For i = LBound(arrKeyCols) To UBound(arrKeyCols)
        rv = rv & sep & data(rowNum, arrKeyCols(i))
        sep = "~~"
    Next i
    RowKey = rv
End Function

'select a random item from a collection, remove it, and return the value
Function RemoveRandom(col As Collection)
    Dim rv, num As Long
    num = Application.RandBetween(1, col.Count)
    RemoveRandom = col(num)
    col.Remove num
End Function