条件を満たす場合にランダムな行をコピー

Question

私は2つの列を持ちます.1つはユーザー名で、もう1つはそれぞれ固有のユーザーの決定です。たとえば、ユーザー名がRohitで、すべてが10％ランダムです。ユーザー決定がNOだった行10％同じユーザーのすべての行がNOの場合、このコードでは列ユーザーのみが固有の名前の10％データを提供しています。

Sub Random10_EveryName() 
    Randomize 'Initialize Random number seed 

    Application.ScreenUpdating = False 

    'Copy Sheet1 to new sheet 
    Sheets("Sheet1").Copy After:=Sheets(Sheets.Count) 

    'Clear old data in Sheet 2 
    Sheets(2).Cells.ClearContents 

    'Determine Number of Rows in Sheet1 Column A 
    numRows = Sheets(Sheets.Count).Cells(Rows.Count, _ 
    "A").End(xlUp).Row 

    'Sort new sheet by Column E 
    Sheets(Sheets.Count).Cells.Sort _ 
    key1:=Sheets(Sheets.Count).Range("O1:D" & numRows), _ 
    order1:=xlAscending, Header:=xlYes 

    'Initialize numNames & startRow variable 
    numNames = 1 
    startRow = 2 

    'Loop through sorted names, count number of current Name 
    For nameRows = startRow To numRows 
    If Sheets(Sheets.Count).Cells(nameRows, "D") = _ 
    Sheets(Sheets.Count).Cells(nameRows + 1, "D") Then 
    numNames = numNames + 1 
    Else: 
    endRow = startRow + numNames - 1 

    'Generate Random row number within current Name Group 
    nxtRnd = Int((endRow - startRow + 1) * _ 
    Rnd + startRow) 

    'Copy row to Sheet2, Delete copied Name 
    dstRow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1 
    Sheets(Sheets.Count).Rows(nxtRnd).EntireRow.Copy _ 
    Destination:=Sheets(2).Cells(dstRow, 1) 
    Sheets(Sheets.Count).Cells(nxtRnd, "D").ClearContents 

    'Set Start Row for next Name Group, reset numNames variable 
    startRow = endRow + 1 
    numNames = 1 
    End If 
    Next 

    'Sort new sheet by Column O 
    Sheets(Sheets.Count).Cells.Sort _ 
    key1:=Sheets(Sheets.Count).Range("O1:E" & numRows), _ 
    order1:=xlAscending, Header:=xlYes 

    'Determine Number of Remaining Names in new sheet Column O 
    numNamesleft = Sheets(Sheets.Count).Cells(Rows.Count, _ 
    "E").End(xlUp).Row - 1 

    'Determine 10% of total entries from Sheet1 
    percRows = _ 
    WorksheetFunction.RoundUp((numRows - 1) * 0.2, 0) 

    'Determine how many extra rows are needed to reach 10% of total 
    unqNames = Sheets(2).Cells(Rows.Count, _ 
    "E").End(xlUp).Row - 1 
    extRows = percRows - unqNames 

    'Warn user if number of Unique Names exceeds 10% of Total Entires 
    If extRows < 0 Then 
    MsgBox "Number of Unique Names Exceeds 10% of Total Entries" 
    'Delete new sheet 
    Application.DisplayAlerts = False 
    Sheets(Sheets.Count).Delete 
    Application.DisplayAlerts = True 
    Exit Sub 
    End If 

    'Extract Random entries from remaining names to reach 10% 
    ' 
    'Allocate elements in Array 
    ReDim MyRows(extRows) 
    'Create Random numbers and fill array 
    For nxtRow = 1 To extRows 
    getNewRnd: 
    'Generate Random row numbers within current Name Group 
    nxtRnd = Int((numNamesleft - 2 + 1) * _ 
    Rnd + 2) 
    'Loop through array, checking for Duplicates 
    For chkRnd = 1 To nxtRow 
    'Get new number if Duplicate is found 
    If MyRows(chkRnd) = nxtRnd Then GoTo getNewRnd 
    Next 
    'Add element if Random number is unique 
    MyRows(nxtRow) = nxtRnd 
    Next 

    'Loop through Array, copying rows to Sheet2 
    For copyrow = 1 To extRows 
    dstRow = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1 
    Sheets(Sheets.Count).Rows(MyRows(copyrow)).EntireRow.Copy _ 
    Destination:=Sheets(2).Cells(dstRow, 1) 
    Next 

    'Delete new sheet 
    Application.DisplayAlerts = False 
    Sheets(Sheets.Count).Delete 
    Application.DisplayAlerts = True 

    End Sub 

Answer 1

あなたは、この（コメント）コード試みることがあります。私はここで何かを行っている

Option Explicit 

Sub main() 
    Dim helpCol As Range, cell As Range 
    Dim resultSht As Worksheet 

    Set resultSht = GetOrCreateSheet("Results") '<--| change "Results" to your wanted name of the "output" sheet 
    With Worksheets("Decisions") '<--| change "Decisions" to your actual data sheet 
     With .Range("O1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference data from in columns "A:O" from row 1 down to last not empty row of column "A" 
      Set helpCol = .Resize(, 1).Offset(, .Parent.UsedRange.Columns(.Parent.UsedRange.Columns.Count).Column) '<-- set a "helper" column where to paste "names" and get unique ones only 
      helpCol.Value = .Resize(, 1).Offset(, 3).Value '<--| paste "names" values from column "D" (i.e. offseted 3 columns from column "A") to "helper" column 
      helpCol.RemoveDuplicates Columns:=Array(1), Header:=xlYes '<-- get only unique "names" in "helper" column 
      For Each cell In helpCol.Offset(1).SpecialCells(xlCellTypeConstants) '<-- loop through unique "names" in "helper" column 
       .AutoFilter field:=4, Criteria1:=cell.Value '<-- filter reference data on 4th column (i.e. column "D") with current "name" 
       Filter2AndWriteRandom .Cells, 5, "YES", 0.1, resultSht '<-- filter again on 5th column (i.e. column "E") with "YES" and write random 10% in "output" sheet 
       Filter2AndWriteRandom .Cells, 5, "NO", 0.1, resultSht '<-- filter again on 5th column (i.e. column "E") with "NO" and write random 10% in "output" sheet 
      Next cell 
     End With 
     helpCol.ClearContents '<-- clear "helper" column 
     .AutoFilterMode = False '<-- show all rows back 
    End With 
End Sub 


Sub Filter2AndWriteRandom(rng As Range, fieldIndex As Long, criterium As String, perc As Double, resultSht As Worksheet) 
    Dim nCells As Long, nPerc As Long, iArea As Long, iRow As Long, iArr As Long 
    Dim sampleRows() As Long 
    Dim filteredRows() As Long 

    With rng '<-- reference passed range 
     .SpecialCells(xlCellTypeVisible).AutoFilter field:=fieldIndex, Criteria1:=criterium '<-- filter on its passed 'filterIndex' column with passed 'criterium' 
     nCells = Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) - 1 '<-- count filtered cells, skipping header one 
     If nCells > 0 Then '<-- if any cell filtered other than header one 
      ReDim filteredRows(1 To nCells) '<-- resize the array that will collect the filtered rows row index 
      With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<-- reference filtered data only 
       For iArea = 1 To .Areas.Count '<-- loop through groups of cells into which data has been filtered down 
        For iRow = 1 To .Areas(iArea).Rows.Count '<-- loop through current 'Area' rows 
         iArr = iArr + 1 '<-- update filtered rows row index index 
         filteredRows(iArr) = .Areas(iArea).Rows(iRow).Row '<-- update filtered rows row index 
        Next iRow 
       Next iArea 
      End With 
      nPerc = WorksheetFunction.RoundUp(nCells * perc, 0) '<-- evaluate the number of rows to be randomly extracted 
      sampleRows = GetRandomSample(nCells, nPerc) '<-- get the array with randomly chosen rows index 
      For iRow = 1 To nPerc '<-- loop through number of rows to be randomly extracted 
       resultSht.Cells(resultSht.Rows.Count, 1).End(xlUp).Offset(1).Resize(, .Columns.Count).Value = .Rows(filteredRows(sampleRows(iRow))).Value '<-- update "output" sheet 
      Next iRow 
     End If 
    End With 
End Sub 

Function GetRandomSample(ByVal nNumbers As Long, nSamples As Long) As Long() 
    Dim numbers() As Long 
    Dim iSample As Long, i As Long 
    ReDim rndNumbers(1 To nSamples) As Long 

    numbers = GetNumbers(nNumbers) 
    For iSample = 1 To nSamples 
     i = Int((nNumbers * Rnd) + 1) 
     rndNumbers(iSample) = numbers(i) 
     numbers(i) = numbers(nNumbers) 
     nNumbers = nNumbers - 1 
    Next iSample 
    GetRandomSample = rndNumbers 
End Function 

Function GetNumbers(nNumbers As Long) As Long() 
    ReDim numbers(1 To nNumbers) As Long 
    Dim i As Long 
    For i = 1 To nNumbers 
     numbers(i) = i 
    Next i 
    GetNumbers = numbers 
End Function 

Function GetOrCreateSheet(shtName As String) As Worksheet 
    On Error Resume Next 
    Set GetOrCreateSheet = Worksheets(shtName) 
    If GetOrCreateSheet Is Nothing Then 
     Set GetOrCreateSheet = Worksheets.Add 
     ActiveSheet.Name = shtName 
    End If 
End Function 

Answer 2

user3598756をあなたがどんな変更を行うことができる唯一の10％の場合、値は= NO DEFECT THAN COPY THAT SO行からの同じユーザと決定を持っています。

Sub test() 
Dim lr As Long, lr2 As Long, R As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long 
Application.ScreenUpdating = False 
Set ws1 = Sheets("Sheet1") 
Set ws2 = Sheets("Sheet2") 
Sheets(2).Cells.ClearContents 
n = 1 
lr = ws1.Cells(Rows.Count, "D").End(xlUp).Row 
lr2 = ws2.Cells(Rows.Count, "E").End(xlUp).Row 
For R = 2 To lr 


If Range("D" & R).Value = "gadrooa" And Range("E" & R).Value = "NO_DEFECT" Then 
Rows(R).Copy Destination:=ws2.Range("A" & n + 1) 
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row 


End If 
Next R 
Application.ScreenUpdating = True 
End Sub