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 :

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"

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

回答1:

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

回答2:

Not sure if I can follow the logic as it is too complex for me. If you don't mind, I worked out an alternative code.

EDIT: I was assuming you can modify the code to get the source/destination. I tested this in excel 2013 and assuming:

the code is running from another work book (not source/destination).
Key is in the first column.

you will modify the oKey and oCnt as per your requirement.

Dim oWS As Worksheet
Dim oWSSrc As Worksheet

Dim oWBSrc As Workbook
Dim oWBDest As Workbook

Dim oRng As Range
Dim oStart As Range
Dim oLast As Range
Dim oMatch As Range
Dim oDest As Range

Dim oKey As Variant
Dim oCnt As Variant

Dim iCnt As Integer
Dim iTot As Integer
Dim iMatch As Integer

oKey = Split("AU,FJ,NZ", ",") '<= modify this
oCnt = Split("4,1,3", ",") ' <= modify this

'Open Destination
Set oWBDest = Application.Workbooks.Open("Tool.xlsm")
Set oWS = oWBDest.Sheets.Add

'Open source workbook
Set oWBSrc = Application.Workbooks.Open("Rawdata.xlsx")
Set oWSSrc = oWBSrc.Sheets("Sheet1")
Set oRng = oWSSrc.Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown))
oRng.Copy oWS.Cells(1, 1)

oWBSrc.Close

'assume key
Set oStart = oWS.Cells(1, 1)

Set oRng = oWS.Range(oStart, oStart.End(xlToRight).End(xlDown).Offset(1))

oWBDest.Sheets("Random Sample").UsedRange.Clear
Set oDest = oWBDest.Sheets("Random Sample").Cells(1, 1)

Randomize

'Assign random numbers for sorting
For iCnt = 1 To oRng.Rows.Count - 1 ' last row is a dummy row do not assign
    oRng.Cells(iCnt, oRng.Columns.Count + 1) = Rnd()
Next

'sort by key (col1) and random number (last col)
With oWS.Sort
    .SortFields.Clear
    .SortFields.Add oWS.Columns(1)
    .SortFields.Add oWS.Columns(oRng.Columns.Count + 1)
    .SetRange oWS.Range(oStart, oStart.End(xlToRight).End(xlDown))
    .Apply
End With

For iCnt = LBound(oKey) To UBound(oKey)

    'Find the first match
    Set oStart = oRng.Find(oKey(iCnt), oRng.Cells(oRng.Rows.Count, 1), xlValues, xlWhole, xlByRows, xlNext)
    Set oLast = oStart ' initiliase

    If Not oStart Is Nothing Then
        '-1 as the first one has been detected
        For iMatch = 1 To CInt(oCnt(iCnt)) - 1
            Set oMatch = oRng.Find(oKey(iCnt), oLast, xlValues, xlWhole, xlByRows, xlNext)

            ' Match the same as start exit (means there are not enough row)
            If oMatch.Address = oStart.Address Then
                Exit For
            Else
                Set oLast = oMatch
            End If
        Next

        'copy the match to output
        Set oStart = oWS.Range(oStart, oLast.Offset(, oRng.Columns.Count - 1))

        oStart.Copy oDest

        If oDest.Offset(1).Value <> "" Then
            Set oDest = oDest.End(xlDown).Offset(1)
        Else
            Set oDest = oDest.Offset(1)
        End If
    End If
Next

'Cleaning up
Application.DisplayAlerts = False
oWS.Delete
Application.DisplayAlerts = True
oWBDest.Save
oWBDest.Close

来源：https://stackoverflow.com/questions/36274110/vba-macro-to-copy-random-rows-based-on-multiple-conditions

标签

vba

random

macros

conditional-statements