VBA/宏根据多个条件复制随机行 [英] VBA/Macro to copy random rows based on multiple conditions

问题描述

我需要帮助才能从具有特定条件的其他工作簿中获取随机行:

I need help to be able to get random rows from another workbook with specific conditions:

如果我单击一个按钮/运行一个宏，我应该得到这样的东西:

If i click a button/run a macro, I should get something like this :

对于所有具有"AU"的行，
• 4个随机行
• 所有具有"FJ"的行的随机行为1
• 所有具有"NC"的行的随机行为1
• 所有具有"NZ"的行的3个随机行
• 所有具有"SG12"的行的随机行为1

• 4 random rows for all rows that has "AU"
• 1 random row for all rows that has "FJ"
• 1 random row for all rows that has "NC"
• 3 random rows for all rows that has "NZ"
• 1 random row for all rows that has "SG12"

从Raw Data_Park Sampling.xlsx"Sheet1"表中的所有内容并将其粘贴到Park Sampling Tool.xlsm"Random Sample"表中.

ALL FROM Raw Data_Park Sampling.xlsx "Sheet1" sheet and paste it to Park Sampling Tool.xlsm "Random Sample" sheet.

所有操作都应一键完成.

All should happen in one click.

下面是我得到的全部代码.

Below is the whole code i got.

Sub MAINx1()


'Delete current random sample

Sheets("Random Sample").Select
Cells.Select
Range("C14").Activate
Selection.Delete Shift:=xlUp




    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
    Dim map, i As Long, n As Long, c As Long, rand, col
    Dim keyArr, nRowsArr
    Dim rng As Range


    Set rawDataWs = Workbooks("Raw Data_Park Sampling.xlsx").Worksheets("Sheet1")
    Set randomSampleWs = Workbooks("Park Sampling Tool.xlsm").Worksheets("Random Sample")
    randomSampleWs.UsedRange.ClearContents

    'Set map = RowMap(rawDataWs.Range("A2:A923"))


     Set rng = rawDataWs.Range("A2:A" & _
                    rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)

    Set map = RowMap(rng)

     keyArr = Array("AU", "FJ", "NC", "NZ", "SG12", "ID", "PH26", "PH24", "TH", "ZA", "JP", "MY", "PH", "SG", "VN") '<== keywords

     nRowsArr = Array(4, 1, 1, 3, 1, 3, 3, 1, 3, 4, 2, 3, 1, 3, 2) '<== # of random rows



    'Debug.Print "Key", "#", "Row#"
    For i = LBound(keyArr) To UBound(keyArr)
        If map.exists(keyArr(i)) Then

            Set col = map(keyArr(i))
            n = nRowsArr(i)

            For c = 1 To n
                'select a random member of the collection
                rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
                'Debug.Print keyArr(i), rand, col(rand)
                rawDataWs.Rows(col(rand)).Copy _
                     randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
                    Exit For
                End If
            Next c

        Else
            'Debug.Print "No rows for " & keyArr(i)
        End If
    Next i

    MsgBox "Random Sample: Per Day Successfully Generated!"


End Sub

'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
    Dim dict, c As Range, k
    Set dict = CreateObject("scripting.dictionary")
    For Each c In rng.Cells
        k = Trim(c.value)
        If Len(k) > 0 Then
            If Not dict.exists(k) Then dict.Add k, New Collection
            dict(k).Add c.Row
        End If
    Next c
    Set RowMap = dict
End Function

推荐答案

从原始代码简化为专注于该方法:

Simplified from your original code to focus on the approach:

Sub MAIN()

    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
    Dim map, i As Long, n As Long, c As Long, rand, col
    Dim keyArr, nRowsArr, rng

    Set rawDataWs = Worksheets("Sheet1")
    Set randomSampleWs = Worksheets("Sheet2")

    randomSampleWs.UsedRange.ClearContents

    'EDIT: dynamic range in ColA
    Set rng  = rawDataWs.Range("A2:A" & _
                    rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)

    Set map = RowMap(rng)

    keyArr = Array("AU", "FJ", "NC", "NZ", "SG12") '<== keywords
    nRowsArr = Array(4, 1, 1, 3, 10) '<== # of random rows

    Debug.Print "Key", "#", "Row#"
    For i = LBound(keyArr) To UBound(keyArr)
        If map.exists(keyArr(i)) Then

            Set col = map(keyArr(i))
            n = nRowsArr(i)

            For c = 1 To n
                'select a random member of the collection
                rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
                Debug.Print keyArr(i), rand, col(rand)
                rawDataWs.Rows(col(rand)).Copy _
                     randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
                    Exit For
                End If
            Next c

        Else
            Debug.Print "No rows for " & keyArr(i)
        End If
    Next i
End Sub

'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
    Dim dict, c As Range, k
    Set dict = CreateObject("scripting.dictionary")
    For Each c In rng.Cells
        k = Trim(c.Value)
        If Len(k) > 0 Then
            If Not dict.exists(k) Then dict.Add k, New Collection
            dict(k).Add c.Row
        End If
    Next c
    Set RowMap = dict
End Function

这篇关于VBA/宏根据多个条件复制随机行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！