用于多种条件的 VBA/宏

Question

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

这是我的数据在rawdata.xlsx中的样子

如果我点击一个按钮/运行一个宏，我应该得到 4 个随机样本 for all rows that has "AU", 1 个随机样本 for all rows that has "FJ", 1 个随机样本 for all rows that has "NC"，3 个随机样本 for all rows that has "NZ"，和1 个随机样本 for all rows that has "SG12" ...

... FROM rawdata.xlsx "Sheet1" sheet 并将其粘贴到 tool.xlsm "Random Sample" sheet.

一切都应该一键完成。

这是我目前的代码：

        Option Explicit

Sub MAIN()
Dim key As String
Dim nKeyCells As Long, nRndRows As Long, rOffset As Long
Dim nRowsArr As Variant, keyArr As Variant
Dim i As Integer
Dim dataRng As Range, helperRng1 As Range, helperRng2 As Range
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet

Set rawDataWs = Workbooks("rawdata.xlsx").Worksheets("Sheet1")
Set randomSampleWs = Workbooks("tool.xlsm").Worksheets("Random Sample")

keyArr = Array("AU", "FJ", "NC", "NZ", "SG12") '<== set your keywords
nRowsArr = Array(4, 1, 1, 3, 1) '<== set the n° of random rows to be associated to its correspondant keyword

With rawDataWs
    Set dataRng = .Range("B2:" & .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column).Address) '<== adapt it to your needs. keywords are assumed to be in the firts column of this range
    Set dataRng = Intersect(.UsedRange, dataRng)
End With

Set helperRng1 = dataRng.Resize(, 1).Offset(, dataRng.Columns.Count + 1) '<== here will be placed "1"s to mark rows to be copied and pasted: they'll be cleared at the end
For i = 0 To UBound(keyArr)
    nRndRows = CInt(nRowsArr(i))
    key = CStr(keyArr(i))
    nKeyCells = WorksheetFunction.CountIf(dataRng.Resize(, 1), key)
    Set helperRng2 = helperRng1.Offset(, 1).Resize(nRndRows) '<== here will be pasted random numbers: they'll be cleared at the end
    Call Unique_Numbers(1, nKeyCells, nRndRows, helperRng2)
    With helperRng1
        .Formula = "=IF(AND(RC" & dataRng.Columns(2).Column & "=""" & key & """,countif(" & helperRng2.Address(ReferenceStyle:=xlR1C1) & ",countif(R" & dataRng.Rows(1).Row & "C" & dataRng.Columns(2).Column & ":RC" & dataRng.Columns(2).Column & ",""" & key & """))>0),1,"""")"
        .value = .value
        Intersect(.EntireRow, dataRng).Copy Destination:=randomSampleWs.Range("A2").Offset(rOffset)
        rOffset = rOffset + nRndRows
        .EntireColumn.Resize(, 2).Clear
    End With
Next i

End Sub


Sub Unique_Numbers(Mn As Long, Mx As Long, Sample As Long, refRange As Range)
Dim tempnum As Long
Dim i As Long
Dim foundCell As Range
' adapted from https://support.microsoft.com/en-us/kb/213290

If Sample > Mx - Mn + 1 Then
    MsgBox "You specified more numbers to return than are possible in the range!"
    Exit Sub
End If

Set refRange = refRange.Resize(Sample, 1)

Randomize
refRange(1) = Int((Mx - Mn + 1) * rnd + Mn)
For i = 2 To Sample
    Set foundCell = Nothing
    Do
       Randomize
       tempnum = Int((Mx - Mn + 1) * rnd + Mn)
       Set foundCell = refRange.Find(tempnum)
    Loop While Not foundCell Is Nothing
    refRange(i) = tempnum
Next

End Sub

Answer 1

试试这个

Option Explicit

Sub MAIN()
Dim key As String
Dim nKeyCells As Long, nRndRows As Long, rOffset As Long
Dim nRowsArr As Variant, keyArr As Variant
Dim i As Integer
Dim dataRng As Range, helperRng1 As Range, helperRng2 As Range
Dim rawDataWs As Worksheet, randomSampleWs As Worksheet

Set rawDataWs = Workbooks("rawdata.xlsx").Worksheets("Sheet1")
Set randomSampleWs = Workbooks("tool.xlsm").Worksheets("Random Sample")

keyArr = Array("AA", "BB", "CC", "DD") '<== set your keywords
nRowsArr = Array(4, 1, 3, 1) '<== set the n° of random rows to be associated to its correspondant keyword

With rawDataWs
    Set dataRng = .Range("A2:E200") '<== adapt it to your needs. keywords are assumed to be in the firts column of this range
    Set dataRng = Intersect(.UsedRange, dataRng)
End With

Set helperRng1 = dataRng.Resize(, 1).Offset(, dataRng.Columns.Count + 1) '<== here will be placed "1"s to mark rows to be copied and pasted: they'll be cleared at the end
For i = 0 To UBound(keyArr)
    nRndRows = CInt(nRowsArr(i))
    key = CStr(keyArr(i))
    nKeyCells = WorksheetFunction.CountIf(dataRng.Resize(, 1), key)
    Set helperRng2 = helperRng1.Offset(, 1).Resize(nRndRows) '<== here will be pasted random numbers: they'll be cleared at the end
    Call Unique_Numbers(1, nKeyCells, nRndRows, helperRng2)
    With helperRng1
        .Formula = "=IF(AND(RC" & dataRng.Columns(1).Column & "=""" & key & """,countif(" & helperRng2.Address(ReferenceStyle:=xlR1C1) & ",countif(R" & dataRng.Rows(1).Row & "C" & dataRng.Columns(1).Column & ":RC" & dataRng.Columns(1).Column & ",""" & key & """))>0),1,"""")"
        .Value = .Value
        Intersect(.SpecialCells(xlCellTypeConstants).EntireRow, dataRng).Copy Destination:=randomSampleWs.Range("A2").Offset(rOffset)
        rOffset = rOffset + nRndRows
        .EntireColumn.Resize(, 2).Clear
    End With
Next i

End Sub


Sub Unique_Numbers(Mn As Long, Mx As Long, Sample As Long, refRange As Range)
Dim tempnum As Long
Dim i As Long
Dim foundCell As Range
' adapted from https://support.microsoft.com/en-us/kb/213290

If Sample > Mx - Mn + 1 Then
    MsgBox "You specified more numbers to return than are possible in the range!"
    Exit Sub
End If

Set refRange = refRange.Resize(Sample, 1)

Randomize
refRange(1) = Int((Mx - Mn + 1) * Rnd + Mn)
For i = 2 To Sample
    Set foundCell = Nothing
    Do
       Randomize
       tempnum = Int((Mx - Mn + 1) * Rnd + Mn)
       Set foundCell = refRange.Find(tempnum)
    Loop While Not foundCell Is Nothing
    refRange(i) = tempnum
Next

End Sub

注意没有限制案例检查/处理