Question

我正在尝试创建一个审核电子表格，该电子表格从另一个电子表格中提取5％的行并将其复制/粘贴到“审核电子表格”中。＆＃34;到目前为止，我已经弄清楚如何进行随机拉动：

Option Explicit
Sub Random20()
Randomize 'Initialize Random number seed
Dim MyRows() As Integer    ' Declare dynamic array.
Dim numRows, percRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer
'Determine Number of Rows in Sheet1 Column A
  numRows = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
'Get 20% of that number
   percRows = numRows * 0.2
'Allocate elements in Array
    ReDim MyRows(percRows) 
'Create Random numbers and fill array
 For nxtRow = 1 To percRows
getNew:
'Generate Random number
  nxtRnd = Int((numRows) * Rnd + 1)
  'Loop through array, checking for Duplicates
   For chkRnd = 1 To nxtRow
 'Get new number if Duplicate is found
        If MyRows(chkRnd) = nxtRnd Then GoTo getNew
       Next
'Add element if Random number is unique
      MyRows(nxtRow) = nxtRnd
 Next
'Loop through Array, copying rows to Sheet2
  For copyRow = 1 To percRows
   Sheets(1).Rows(MyRows(copyRow)).EntireRow.Copy _
     Destination:=Sheets(2).Cells(copyRow, 1)
  Next
End Sub

我正在寻找一种方法来调整，以便用户选择要从中提取的文件，并自动填充自己的Excel电子表格以进行审核。

此外，还有两个标题行。

Answer 1

我认为会做你需要的：

Sub Audit()

Dim otherWorkbook As Excel.Workbook
Dim fileName As String
Dim i As Long, x As Long, y As Long
Dim rowNumbers As Object
Dim auditNumber As Long

Set rowNumbers = CreateObject("System.Collections.ArrayList")

fileName = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")

If Not LCase(fileName) = "false" Then
    Set otherWorkbook = Workbooks.Open(fileName)

    auditNumber = otherWorkbook.Sheets(1).Find(What:="*", After:=otherWorkbook.Sheets(1).Cells(1), _
           Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, MatchCase:=False).Row * 0.2 '// 0.2 = 20%

    rowNumbers.Add WorksheetFunction.RandBetween(3, auditNumber)

    While rowNumbers.Count < auditNumber
        y = WorksheetFunction.RandBetween(3, otherWorkbook.Sheets(1).UsedRange.Rows.Count)
        If Not rowNumbers.Contains(y) Then rowNumbers.Add y
    Wend

    For i = 0 To rowNumbers.Count - 1
        x = x + 1
        otherWorkbook.Sheets(1).Rows(rowNumbers(i)).EntireRow.Copy _
           Destination:=ThisWorkbook.Sheets(1).Cells(x, 1)
    Next

End If

Answer 2

以下是您所需要的一切：

Sub GetRandomRows()
    PULLPERCENT = 0.05
    Dim i&, j&, k&, n&, r, s, v, wb As Workbook
    s = Application.GetOpenFilename("Excel Files *.xls* (*.xls*),")
    If s <> False Then
        Set wb = Workbooks.Open(s)
        n = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
        s = ""
        Randomize
        Do
            j = Int(n * Rnd + 1)
            If InStr(s, "." & j) = 0 Then
                s = s & "." & j
                k = k + 1
            End If
        Loop Until (k > n * PULLPERCENT)
        r = Split(s, ".")
        For i = 1 To n * PULLPERCENT
            v = wb.Worksheets(1).Rows(2 + r(i)).EntireRow
            ThisWorkbook.Worksheets(2).Cells(i, 1).EntireRow = v
        Next
        wb.Close False
    End If
End Sub

从另一个文件中提取随机行

2 个答案: