VBA/Makro zufällige Zeilen zu kopieren, basierend auf mehreren Bedingungen

Question

Ich brauche Hilfe zufällige Zeilen mit bestimmten Bedingungen von einer anderen Arbeitsmappe erhalten zu können:

Wenn ich auf eine Schaltfläche klicken/ein Makro ausführen, soll ich so etwas wie erhalten Dieser:

• 4 zufällige Zeilen für alle Zeilen, die „AU“
• 1 zufällige Zeile für alle Zeilen hat, die „FJ“
• 1 zufällige Zeile für alle Zeilen hat, die „NC“
• hat 3 zufällige Zeilen für Alle Zeilen, die für alle Zeilen, die "SG12" hat

FROM ALL Raw Data_Park Sampling.xlsx "Sheet1" Blatt und fügen es Park Sampling Tool.xlsm "Random Sample" sheet "NZ"

1 zufällige Reihe hat.

Alles sollte mit einem Klick geschehen.

Unten ist der ganze Code, den ich bekam.

Sub MAINx1() 


'Delete current random sample 

Sheets("Random Sample").Select 
Cells.Select 
Range("C14").Activate 
Selection.Delete Shift:=xlUp 




    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet 
    Dim map, i As Long, n As Long, c As Long, rand, col 
    Dim keyArr, nRowsArr 
    Dim rng As Range 


    Set rawDataWs = Workbooks("Raw Data_Park Sampling.xlsx").Worksheets("Sheet1") 
    Set randomSampleWs = Workbooks("Park Sampling Tool.xlsm").Worksheets("Random Sample") 
    randomSampleWs.UsedRange.ClearContents 

    'Set map = RowMap(rawDataWs.Range("A2:A923")) 


    Set rng = rawDataWs.Range("A2:A" & _ 
        rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row) 

    Set map = RowMap(rng) 

    keyArr = Array("AU", "FJ", "NC", "NZ", "SG12", "ID", "PH26", "PH24", "TH", "ZA", "JP", "MY", "PH", "SG", "VN") '<== keywords 

    nRowsArr = Array(4, 1, 1, 3, 1, 3, 3, 1, 3, 4, 2, 3, 1, 3, 2) '<== # of random rows 



    'Debug.Print "Key", "#", "Row#" 
    For i = LBound(keyArr) To UBound(keyArr) 
     If map.exists(keyArr(i)) Then 

      Set col = map(keyArr(i)) 
      n = nRowsArr(i) 

      For c = 1 To n 
       'select a random member of the collection 
       rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")") 
       'Debug.Print keyArr(i), rand, col(rand) 
       rawDataWs.Rows(col(rand)).Copy _ 
        randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
       col.Remove rand 'remove the "used" row 
       If col.Count = 0 Then 
        If c < n Then Debug.Print "Not enough rows for " & keyArr(i) 
        Exit For 
       End If 
      Next c 

     Else 
      'Debug.Print "No rows for " & keyArr(i) 
     End If 
    Next i 

    MsgBox "Random Sample: Per Day Successfully Generated!" 


End Sub 

'get a map of rows as a dictionary where each value is a collection of row numbers 
Function RowMap(rng As Range) As Object 
    Dim dict, c As Range, k 
    Set dict = CreateObject("scripting.dictionary") 
    For Each c In rng.Cells 
     k = Trim(c.value) 
     If Len(k) > 0 Then 
      If Not dict.exists(k) Then dict.Add k, New Collection 
      dict(k).Add c.Row 
     End If 
    Next c 
    Set RowMap = dict 
End Function 

Answer 1

von Ihrem ursprünglichen Code Vereinfachtes auf dem Ansatz zu konzentrieren:

Sub MAIN() 

    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet 
    Dim map, i As Long, n As Long, c As Long, rand, col 
    Dim keyArr, nRowsArr, rng 

    Set rawDataWs = Worksheets("Sheet1") 
    Set randomSampleWs = Worksheets("Sheet2") 

    randomSampleWs.UsedRange.ClearContents 

    'EDIT: dynamic range in ColA 
    Set rng = rawDataWs.Range("A2:A" & _ 
        rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row) 

    Set map = RowMap(rng) 

    keyArr = Array("AU", "FJ", "NC", "NZ", "SG12") '<== keywords 
    nRowsArr = Array(4, 1, 1, 3, 10) '<== # of random rows 

    Debug.Print "Key", "#", "Row#" 
    For i = LBound(keyArr) To UBound(keyArr) 
     If map.exists(keyArr(i)) Then 

      Set col = map(keyArr(i)) 
      n = nRowsArr(i) 

      For c = 1 To n 
       'select a random member of the collection 
       rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")") 
       Debug.Print keyArr(i), rand, col(rand) 
       rawDataWs.Rows(col(rand)).Copy _ 
        randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 
       col.Remove rand 'remove the "used" row 
       If col.Count = 0 Then 
        If c < n Then Debug.Print "Not enough rows for " & keyArr(i) 
        Exit For 
       End If 
      Next c 

     Else 
      Debug.Print "No rows for " & keyArr(i) 
     End If 
    Next i 
End Sub 

'get a map of rows as a dictionary where each value is a collection of row numbers 
Function RowMap(rng As Range) As Object 
    Dim dict, c As Range, k 
    Set dict = CreateObject("scripting.dictionary") 
    For Each c In rng.Cells 
     k = Trim(c.Value) 
     If Len(k) > 0 Then 
      If Not dict.exists(k) Then dict.Add k, New Collection 
      dict(k).Add c.Row 
     End If 
    Next c 
    Set RowMap = dict 
End Function 

Answer 2

Nicht sicher, ob ich der Logik folgen kann, wie es für mich zu komplex ist. Wenn es Ihnen nichts ausmacht, habe ich einen alternativen Code ausgearbeitet.

EDIT: Ich nahm an, dass Sie den Code ändern können, um die Quelle/Ziel zu erhalten. Ich testete dies in Excel 2013 und unter der Annahme:

• der Code läuft von einem anderen Arbeitsbuch (nicht Quelle/Ziel).
• Schlüssel ist in der ersten Spalte.

• Sie werden den oKey und oCnt gemäß Ihrer Anforderung ändern.

  Dim oWS As Worksheet 
  Dim oWSSrc As Worksheet 
  
  Dim oWBSrc As Workbook 
  Dim oWBDest As Workbook 
  
  Dim oRng As Range 
  Dim oStart As Range 
  Dim oLast As Range 
  Dim oMatch As Range 
  Dim oDest As Range 
  
  Dim oKey As Variant 
  Dim oCnt As Variant 
  
  Dim iCnt As Integer 
  Dim iTot As Integer 
  Dim iMatch As Integer 
  
  oKey = Split("AU,FJ,NZ", ",") '<= modify this 
  oCnt = Split("4,1,3", ",") ' <= modify this 
  
  'Open Destination 
  Set oWBDest = Application.Workbooks.Open("Tool.xlsm") 
  Set oWS = oWBDest.Sheets.Add 
  
  'Open source workbook 
  Set oWBSrc = Application.Workbooks.Open("Rawdata.xlsx") 
  Set oWSSrc = oWBSrc.Sheets("Sheet1") 
  Set oRng = oWSSrc.Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)) 
  oRng.Copy oWS.Cells(1, 1) 
  
  oWBSrc.Close 
  
  'assume key 
  Set oStart = oWS.Cells(1, 1) 
  
  Set oRng = oWS.Range(oStart, oStart.End(xlToRight).End(xlDown).Offset(1)) 
  
  oWBDest.Sheets("Random Sample").UsedRange.Clear 
  Set oDest = oWBDest.Sheets("Random Sample").Cells(1, 1) 
  
  Randomize 
  
  'Assign random numbers for sorting 
  For iCnt = 1 To oRng.Rows.Count - 1 ' last row is a dummy row do not assign 
      oRng.Cells(iCnt, oRng.Columns.Count + 1) = Rnd() 
  Next 
  
  'sort by key (col1) and random number (last col) 
  With oWS.Sort 
      .SortFields.Clear 
      .SortFields.Add oWS.Columns(1) 
      .SortFields.Add oWS.Columns(oRng.Columns.Count + 1) 
      .SetRange oWS.Range(oStart, oStart.End(xlToRight).End(xlDown)) 
      .Apply 
  End With 
  
  For iCnt = LBound(oKey) To UBound(oKey) 
  
      'Find the first match 
      Set oStart = oRng.Find(oKey(iCnt), oRng.Cells(oRng.Rows.Count, 1), xlValues, xlWhole, xlByRows, xlNext) 
      Set oLast = oStart ' initiliase 
  
      If Not oStart Is Nothing Then 
       '-1 as the first one has been detected 
       For iMatch = 1 To CInt(oCnt(iCnt)) - 1 
        Set oMatch = oRng.Find(oKey(iCnt), oLast, xlValues, xlWhole, xlByRows, xlNext) 
  
        ' Match the same as start exit (means there are not enough row) 
        If oMatch.Address = oStart.Address Then 
         Exit For 
        Else 
         Set oLast = oMatch 
        End If 
       Next 
  
       'copy the match to output 
       Set oStart = oWS.Range(oStart, oLast.Offset(, oRng.Columns.Count - 1)) 
  
       oStart.Copy oDest 
  
       If oDest.Offset(1).Value <> "" Then 
        Set oDest = oDest.End(xlDown).Offset(1) 
       Else 
        Set oDest = oDest.Offset(1) 
       End If 
      End If 
  Next 
  
  'Cleaning up 
  Application.DisplayAlerts = False 
  oWS.Delete 
  Application.DisplayAlerts = True 
  oWBDest.Save 
  oWBDest.Close