VBA/Makro für mehrere Bedingung

Question

Ich brauche Hilfe von Zufallsdaten aus einer anderen Arbeitsmappe mit spezifischen Bedingungen erhalten zu können:

hier ist, wie sehen meine Daten wie in rawdata.xlsx

Wenn i klicken Sie auf eine Schaltfläche/ein Makro ausführen, sollte ich 4 Stichprobenfor all rows that has "AU", 1 Stichprobefor all rows that has "FJ", 1 Stichprobe erhaltenfor all rows that has "NC", 3 Stichprobenfor all rows that has "NZ" und 1 Stichprobefor all rows that has "SG12" ...

... FROM rawdata.xlsx "Sheet1" Blatt und an tool.xlsm "Random Sample" Blatt einfügen.

Alles sollte mit einem Klick geschehen.

Dies ist mein Code so weit:

 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

versuchen diese

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 

passen keine Grenzfälle gibt es die Überprüfung/Handling