lundi 28 mars 2016

VBA/Macro to copy random rows based on multiple conditions

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