适用于多种情况的VBA / Macro

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" ... < / p>

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

只需点击一下即可完成。

到目前为止，这是我的代码：

        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

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