VBA /macros为多个条件

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

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

如果我点击一个button/运行一个macros，我应该得到for all rows that has "AU" 4个随机样本， for all rows that has "AU" for all rows that has "FJ" for all rows that has "NC" 1个随机样本， for all rows that has "NC" 1个随机样本 ， 3 for all rows that has "NZ" for all rows that has "SG12" 随机样本 ，以及for all rows that has "SG12" 随机样本 …

…从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 

请注意，没有限制的情况下检查/处理