Vba 从另一个文件中随机抽取行

我正在尝试创建一个审计电子表格，从另一个电子表格中提取5%的行，并将它们复制/粘贴到“审计电子表格”中。到目前为止，我已经知道如何通过以下方式进行随机提取：

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电子表格，以便进行审计

---

此外，还有两个标题行。

我认为可以满足您的需要：

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

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

子审计（）
将其他工作簿设置为Excel.工作簿
将文件名设置为字符串
我长，x长，y长
将行数变暗为对象
数字越长越好
设置RowNumber=CreateObject（“System.Collections.ArrayList”）
fileName=Application.GetOpenFilename（“Excel文件（*.xls*），*.xls*））
如果不是LCase（文件名）=“false”，则
设置其他工作簿=工作簿。打开（文件名）
auditNumber=otherWorkbook.Sheets（1）.查找（内容：=“*”，后面：=otherWorkbook.Sheets（1）.单元格（1）_
Lookat:=xlPart，LookIn:=xlFormulas，SearchOrder:=xlByRows_
SearchDirection:=xlPrevious，MatchCase:=False）。行*0.2'//0.2=20%
RowNumber.Add WorksheetFunction.RandBetween（3，auditNumber）
而rowNumbers.Count

以下是您所需要的：

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

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

子GetRandomRows（）
PULLPERCENT=0.05
尺寸i&，j&，k&，n&，r，s，v，wb作为工作簿
s=Application.GetOpenFilename（“Excel文件*.xls*（*.xls*），”）
如果是假的话
设置wb=工作簿。打开（s）
n=工作表（1）.范围（“A”&行数）.结束（xlUp）.行
s=“”
随机化
做
j=Int（n*Rnd+1）
如果仪表（s，“.”和j）=0，则
s=s&“&j
k=k+1
如果结束
循环直到（k>n*PULLPERCENT）
r=拆分
对于i=1到n*PULLPERCENT
v=wb.工作表（1）.行（2+r（i））.EntireRow
此工作簿。工作表（2）。单元格（i，1）。EntireRow=v
下一个
wb.关闭错误
如果结束
端接头

要审核的工作簿中的数据从哪一行开始？有标题行吗？有。有两个标题行。我正要把它添加到我的问题中。auditNumber没有定义，而且，我看不到它在哪里检查以确保它没有复制重复的行。在最后一分钟进行了编辑，没有发现它！请参见上面的编辑：）

确保它没有复制重复的行

，然后使用

ArrayList

对象和

.Contains（）

方法确保选择了唯一的数字。现在它告诉我无法获取WOrksheetFunction类@RowNumber的RandBetween属性。添加WOrksheetFunction.RandBetween（3，auditNumber）另外，那个人在这个工作簿上给了我一个错误“下标超出范围”。工作表（16）。单元格（i，1）.EntireRow=vSo，这一个现在正在做的是快速打开另一个excel，然后关闭它，而不将任何内容粘贴到审核excel中。确定。因此，这一次它复制并粘贴了第1、2和5行，并丢失了许多列。