我有两个列，一个是用户名，另一个是现在决定我想要10％数据的每个唯一用户..例如，如果用户名是Rohit并且决定是，则用户决定为是的所有行的10％随机再次对于同一用户的所有行没有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
答案 0 :(得分：0)
你可以尝试这个（注释）代码：
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
答案 1 :(得分：0)
user3598756我已经完成了一些事情，你可以做任何改变，因为如果价值=没有比只有相同用户和决定的行只有10％复制的话。
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