VBA/宏根据多个条件复制随机行

Posted 2023-03-14

【中文标题】VBA/宏根据多个条件复制随机行

【英文标题】：VBA/Macro to copy random rows based on multiple conditions

【发布时间】：2016-07-16 09:46:09

【问题描述】：

我需要帮助才能从具有特定条件的另一个工作簿中获取随机行：

如果我点击一个按钮/运行一个宏，我应该得到这样的结果：

包含“AU”的所有行的 4 个随机行 1 个随机行，用于所有具有“FJ”的行 1 个随机行，用于所有具有“NC”的行 包含“NZ”的所有行的 3 个随机行 1 个随机行，用于所有具有“SG12​​”的行

ALL FROM Raw Data_Park Sampling.xlsx "Sheet1" 表并将其粘贴到 Park Sampling Tool.xlsm "Random Sample" 表。

一切都应该一键完成。

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

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

【问题讨论】：

Set map = RowMap(rawDataWs.Range("A2:A23")) 你调整这条线了吗？请不要更新您的原始问题以用我的答案替换您的代码：如果您只是在我的答案中添加评论，以后来的人会更容易关注。

【参考方案1】：

不确定我是否可以遵循逻辑，因为它对我来说太复杂了。如果你不介意，我制定了一个替代代码。

编辑： 我假设您可以修改代码以获取源/目标。我在 excel 2013 中对此进行了测试并假设：

代码从另一个工作簿（不是源/目标）运行。 键在第一列。

您将根据需要修改 oKey 和 oCnt。

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

【参考方案2】：

从您的原始代码简化到专注于方法：

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，我现在很难完成我想要完成的事情

你调整了“A2:A23”吗？那只是我使用包含一些测试数据的固定输入范围的简化代码。对于测试，您只需将其硬编码到当前数据集即可。

是的，我确实改变了。我刚刚检查了我使用的 rawdata.xlsx 并对其进行了修改。也许是有问题的那个。我有一个问题。如何将范围设置为动态？因为我每天都会有不同数量的数据。我尝试使用 rawDataWs Set map = RowMap(rawDataWs.Range("A2:" & .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count)。 End(xlToLeft).Column).Address) End With 但似乎不起作用

查看我的编辑。我正在复制整行 - 如果这是一个问题，您需要修改 Copy 行

我也有同样的想法。我试过了，我得到了编译错误：ByRef 参数类型不匹配编辑：我试过 Dim rng As Range，它现在可以工作了。谢谢！如果我遇到另一个问题，我会再次在这里发表评论