Question

这是我的代码：我有3％的数据提取代码，在多个重复请求中，我必须为每个请求选择3％的数据，任何人都可以帮助我。

Option Explicit
Option Base 1
Sub CopyRows()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList() 
Dim i As Long, j As Long, k As Long 
Dim RowNb As Long 
'Sheets("Sheet1").Activate 
LastRow = Range("A" & Rows.Count).End(xlUp).Row 
NbRows = IIf(LastRow <> 200, LastRow * 0.03, 20) 
ReDim RowList(1 To NbRows) 
k = 1 
For i = 1 To NbRows RowNb = Rnd() * LastRow 
For j = 1 To k 
If (RowList(j) = RowNb) Then GoTo NextStep 
Next j RowList(k) = RowNb Rows(RowNb).Copy 
Destination:=Sheets("Sheet2").Cells(k, "A") 
k = k + 1 
NextStep: Next i End Sub`

以下是示例数据：

Request Processor Name  Status  Process
131 Ibrar   Completed   CRU
131 Ibrar   Completed   CRU
131 Ibrar   Completed   CRU
131 Ibrar   Completed   CRU
131 Ibrar   Completed   CRU
131 Ibrar   Completed   CRU
131 Ibrar   Completed   CRU
131 Amrita  Completed   CRU
131 Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU
97  Amrita  Completed   CRU

我需要提取131％的3％和97％的3％。

Answer 1

尝试以下内容。注意，如果3％小于1行，我选择1行，否则我使用Floor函数向下舍入到最接近的整数。你可以改变它。

从Ozgrid修改的功能。包括链接。

测试用例：

样本数据为：

注意：我在E列中添加了一个唯一的行Id，因此可以检查行选择的结果。

在我的示例中，共有9行Request 97，87行Request 131。所选行数的预期结果如下表所示：

结果行数：

使用数据进行测试：

<强>代码：

Option Explicit

Public Sub PasteSampleRows()
    Dim lastRow As Long, dict As Object, arr(),  i As Long, ws As Worksheet
    Set ws = Worksheets("Sheet1")

    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        arr = .Range("A2:E" & lastRow).Value
        Set dict = CreateObject("Scripting.Dictionary")

        For i = LBound(arr, 1) To UBound(arr, 1) '<= Get distinct Request and count of associated rows
            If Not dict.exists(arr(i, 1)) Then
                dict.Add (arr(i, 1)), 1
            Else
                dict(arr(i, 1)) = dict(arr(i, 1)) + 1
            End If
        Next i

        Dim key As Variant

        For Each key In dict.keys
            With .Range("A1:E" & lastRow)
                .AutoFilter Field:=1, Criteria1:=key
                Dim targetNumberRows As Long
                targetNumberRows = Application.WorksheetFunction.Floor(0.03 * dict(key), 1)
                If targetNumberRows < 1 Then targetNumberRows = 1
                Dim tempString As String, selectedRows As Range
                tempString = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).Address
                Set selectedRows = RandRows(ws, Replace(Split(tempString, "$")(2), ":", vbNullString), Split(tempString, "$")(4), targetNumberRows)
            End With
            With Worksheets("Sheet2")
                If Not selectedRows Is Nothing Then
                    selectedRows.Copy .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
                End If
            End With
            .AutoFilterMode = False
        Next key
    End With
End Sub

Private Function RandRows(ByRef currSheet As Worksheet, ByVal firstRow As Long, ByVal lastRow As Long, ByVal numRows As Long) As Range
    'http://www.ozgrid.com/VBA/RandomNumbers.htm
    Dim iArr As Variant, selectedRows As Range, i As Long, r As Long, temp As Long

    Application.Volatile

    ReDim iArr(firstRow To lastRow)

    For i = firstRow To lastRow
        iArr(i) = i
    Next i

    For i = lastRow To firstRow + 1 Step -1
        r = Int(Rnd() * (i - firstRow + 1)) + firstRow
        temp = iArr(r)
        iArr(r) = iArr(i)
        iArr(i) = temp
    Next i

    Dim currRow As Range

    For i = firstRow To firstRow + numRows - 1
        Set currRow = currSheet.Cells.Rows(iArr(i))
        If Not selectedRows Is Nothing Then
            Set selectedRows = Application.Union(selectedRows, currRow)
        Else
            Set selectedRows = currRow
        End If
    Next i

    If Not selectedRows Is Nothing Then
        Set RandRows = selectedRows
    Else
        MsgBox "No rows were selected for copying"
    End If

End Function

每个请求需要3％的数据

1 个答案: