I need help to be able to get random data from another worksheet with specific conditions:
If i click a button/run a macro, I should get 4 random samples for all rows that has "AU"
, 1 random sample for all rows that has "FJ"
, 1 random sample for all rows that has "NC"
, 3 random samples for all rows that has "NZ"
, and 1 random sample for all rows that has "SG12"
...
... FROM rawdata.xlsx "Sheet1"
sheet and paste it to tool.xlsm "Random Sample"
sheet.
All should happen in one click.
I am getting Error 1004: No cells were found and being directed tho this line of code:
Intersect(.SpecialCells(xlCellTypeConstants).EntireRow, dataRng).Copy Destination:=randomSampleWs.Range("B2").Offset(rOffset)
This is my whole code so far:
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(.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 http://ift.tt/1RCOxAU
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
Aucun commentaire:
Enregistrer un commentaire