Question

我有一个来自另一个宏的输出excel文件，它有多个工作表（名为100,101,102 ......等）。工作表编号会因先前宏的输出而异。

还有一张名为sheet1的工作表，其中包含有关应从100,101,102等中选择多少随机行的信息。

我尝试合并/组合我可以从类似的宏中找到的东西，但我想循环部分已经超出了我的想法。

我将从另一个“主”excel运行宏。这将打开相关的输出xls。

然后它将从sheet1中查找随机行数量，然后在相关工作表中选择该数量的随机行并移至下一个工作表。（我从查找中获得了正确的金额（使用了索引匹配））

但对于随机部分，我无法使其适用于多张纸。

选择并着色行或副本并将它们粘贴到另一张/ wb无关紧要。两者都没问题，但我需要自动化这个过程，因为我有太多的数据在等待。

到目前为止我管理的宏是下面的，因为我是新手，可能会有无关或不必要的事情。

有可能吗？

Sub RANDOM()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Sh As Worksheet
Dim Durat As Long
StartTime = Now()
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Integer
Dim I As Long

FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" & 
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value 
& " Muavinbol" & ".xls")

SheetN = mvn.Worksheets.Count
Set SampleS = mvn.Sheets("Sheet1")

For Each Sh In mvn.Worksheets
    Sh.Activate
    If Sh.Name <> "Sheet1" Then
        Dim lookupvalue As Integer
        Dim ranrows As Integer
        Dim randrows As Integer
     lookupvalue = Cells(1, 1).Value
     ranrows = Application.WorksheetFunction.Index(mvn.Sheets("Sheet1")_
.Range("S1:S304"), Application.WorksheetFunction.Match(lookupvalue, 
mvn.Sheets("Sheet1").Range("$D$1:$D$304"), 0))

'MsgBox lookupvalue & " " & ranrows
    End If

Next Sh

Durat = Round((Now() - StartTime) * 24 * 60 * 60, 0)

'MsgBox Durat & " seconds."

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Answer 1

这是一个例子（我已经整合了一些代码，改编自其他地方，并将参考添加到代码本身）我会欢迎其他用户的反馈并且可以改进。

Sheet1包含要返回的行数和工作表名称（我使用了一个简短列表）

其他工作表有一些随机数据，例如Sheet2

代码将工作表名称读入一个数组，并从每个工作表中随机选择行数到另一个数组。

然后循环工作表，通过在工作表中的第一行和起始行之间进行选择来生成所需的随机行数（如果指定的随机行数超过可用数，则当前没有错误处理，但是可以将numRows设置为lastRow。Union用于收集给定工作表的这些内容，并将它们复制到另一个工作簿的目标工作表中的下一个可用行.Union can＆＃ 39;不能在工作表中使用，所以必须找到一个解决方法，我为每个工作表选择了这个副本。

我已经做了一些假设，关于从哪里复制，但有一个游戏。我还留下了一些代码，目前set mnv = ThisWorkbook和要复制的工作簿称为otherWorkbook。你的名字和目标可能有所不同，但这是为了向你展示一个生成数字并在循环中复制它们的过程。

使用了Rory的一个函数来测试工作表是否存在。

示例结果：

Option Explicit

Public Sub RANDOM()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim Sh As Worksheet
    Dim Durat As Long

    Dim mvn As Workbook
    Dim FPath As String
    Dim newWB As Workbook
    'Dim SheetN As Long
    Dim i As Long
    Dim otherWorkbook As Workbook
    Dim targetSheet As Worksheet
    Dim startTime As Date
    Dim mnv As Workbook
    Dim SampleS As Worksheet

    startTime = Now()

    FPath = ThisWorkbook.Path

    'Set mvn = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\" & Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value & " Muavinbol" & ".xls")

    Set mnv = ThisWorkbook

    Set otherWorkbook = Workbooks.Open("C:\Users\HarrisQ\Desktop\My Test Folder\Test.xlsx")

    Set targetSheet = otherWorkbook.Sheets("TargetSheet")
    Set SampleS = mnv.Worksheets("Sheet1")

    Dim worksheetNames()
    Dim numRandRows()

    worksheetNames = SampleS.Range("$D$1:$D$3").Value
    numRandRows = SampleS.Range("$S$1:$S$3").Value

    Dim copyRange As Range

    Dim currSheetIndex As Long
    Dim currSheet As Worksheet

    Dim selectedRows As Range

    For currSheetIndex = LBound(worksheetNames, 1) To UBound(worksheetNames, 1)


        If WorksheetExists(CStr(worksheetNames(currSheetIndex, 1))) Then

            Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))

            With currSheet

                Dim firstRow As Long
                Dim lastRow As Long
                Dim numRows As Long

                firstRow = GetFirstLastRow(currSheet, 1)(0) 'I am using Column A (1) to specify column to use to find first and last row.
                lastRow = GetFirstLastRow(currSheet, 1)(1)
                numRows = numRandRows(currSheetIndex, 1)

                Set selectedRows = RandRows(currSheet, firstRow, lastRow, numRows) 'Union cannot span different worksheets so copy paste at this point

                Dim nextTargetRow As Long

                If IsEmpty(targetSheet.Range("A1")) Then
                    nextTargetRow = 1
                Else
                    nextTargetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
                End If

                selectedRows.Copy targetSheet.Cells(nextTargetRow, 1)

                Set selectedRows = Nothing
            End With

        End If

    Next currSheetIndex


    Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)

    'MsgBox Durat & " seconds."

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

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
    Dim selectedRows As Range

    Dim i As Long

    Dim r As Long

    Dim 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

Private Function GetFirstLastRow(ByRef currSheet As Worksheet, ByVal colNum As Long) As Variant
    'colNum determine which column you will use to find last row
    Dim startRow As Long
    Dim endRow As Long

    endRow = currSheet.Cells(currSheet.Rows.Count, colNum).End(xlUp).Row

    startRow = FirstUsedCell(currSheet, colNum)


    GetFirstLastRow = Array(startRow, endRow)

End Function

Private Function FirstUsedCell(ByRef currSheet As Worksheet, ByVal colNum As Long) As Long
    'Finds the first non-blank cell in a worksheet.
    'https://www.excelcampus.com/library/find-the-first-used-cell-vba-macro/
    Dim rFound As Range

    On Error Resume Next
    Set rFound = currSheet.Cells.Find(What:="*", _
                                      After:=currSheet.Cells(currSheet.Rows.Count, colNum), _
                                      LookAt:=xlPart, _
                                      LookIn:=xlFormulas, _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlNext, _
                                      MatchCase:=False)

    On Error GoTo 0

    If rFound Is Nothing Then
        MsgBox currSheet & ":All cells are blank."
        End
    Else
        FirstUsedCell = rFound.Row
    End If

End Function



Function WorksheetExists(sName As String) As Boolean
'@Rory https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Answer 2

由于QHarr的代码需要在工作簿中存在所有工作表名称，因此最终对我不起作用。但是，通过合并一些其他项目的功能，我使它发挥作用。

在同一文件夹中打开输出xlsx文件，索引和匹配以查找随机行数量循环遍历所有具有随机功能的工作表然后将所有随机行粘贴到名为RASSAL

的工作表中

可能效率不高，因为我真的没有太多关于代码的信息，但我想我设法将其修改为我的需求。

无论如何都要接受建议，非常感谢@QHarr对他/她的回复。

Sub RASSALFNL()

'Application.ScreenUpdating = False
'Application.DisplayAlerts = False

Dim Durat As Long
startTime = Now()

Dim Sht As Worksheet
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Long
Dim i As Long
Dim lookupvalue As Long
Dim indexrange As Range
Dim matchrange As Range
Dim ranrows As Long
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
Dim sayf As String
Dim nextTargetRow As Long
Dim Rassal As Worksheet
Dim rngToCopy As Range
Dim sampleCount As Long
Dim ar() As Long
Dim total As Long
Dim rowhc As Long

FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" & 
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value 
& " Muavinbol" & ".xlsx")
SheetN = mvn.Worksheets.count
Set SampleS = mvn.Sheets("Sheet1")
Set Rassal = Worksheets.Add
Rassal.Name = "RASSAL"

Set indexrange = SampleS.Range("$S$8:$S$304")
Set matchrange = SampleS.Range("$D$8:$D$304")

mvn.Activate
For Each Sht In mvn.Worksheets
Sht.Activate
    If Sht.Name = "Sheet1" Or Sht.Name = "Sayfa1" Or Sht.Name = "RASSAL" 
Then
    'do nothing
    Else
        lookupvalue = Sht.Cells(1, 1).Value
        ranrows = Application.WorksheetFunction.Index(indexrange, 
Application.WorksheetFunction.Match(lookupvalue, matchrange, 0))
        With Sht
             firstRow = GetFirstLastRow(Sht, 1)(0)
             lastRow = GetFirstLastRow(Sht, 1)(1)
             numRows = ranrows
             sayf = Sht.Name
             'MsgBox sayf & " " & firstRow & " " & lastRow & " " & 
ranrows 
          If numRows = 0 Then
          'do nothing
          Else
             ar = UniqueRandom(numRows, firstRow, lastRow)
             Set rngToCopy = .Rows(ar(0))
             For i = 1 To UBound(ar)
             Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
             Next

                    If IsEmpty(mvn.Sheets("RASSAL").Range("A1")) Then
                    nextTargetRow = 1
                    Else
                    nextTargetRow = 
mvn.Sheets("RASSAL").Cells(mvn.Sheets("RASSAL").Rows.count, 
"A").End(xlUp).Row + 1
                    End If
                    rngToCopy.Copy Rassal.Cells(nextTargetRow, 1)
                    Set rngToCopy = Nothing
          End If
        End With
    End If
Next Sht

rowhc = Rassal.Cells(Rows.count, 1).End(xlUp).Row

Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
MsgBox rowhc & " " & "random selections made in" & " " & Durat & " 
seconds."

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Private Function GetFirstLastRow(ByRef Sht As Worksheet, ByVal colNum As 
Long) As Variant
'colNum determine which column you will use to find last row
Dim firstRow As Long
Dim lastRow As Long

lastRow = Sht.Cells(Sht.Rows.count, colNum).End(xlUp).Row
firstRow = FirstUsedCell(Sht, colNum)

GetFirstLastRow = Array(firstRow, lastRow)

End Function

Private Function FirstUsedCell(ByRef Sht As Worksheet, ByVal colNum As 
Long) As Long
Dim rFound As Range
On Error Resume Next
Set rFound = Sht.Cells.Find(What:="*", _
                                  After:=Sht.Cells(Sht.Rows.count, 
colNum), _
                                  LookAt:=xlPart, _
                                  LookIn:=xlFormulas, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, _
                                  MatchCase:=False)

On Error GoTo 0

If rFound Is Nothing Then
    'do Nothing MsgBox Sh & ":All cells are blank."
    End
Else
    FirstUsedCell = rFound.Row
End If

End Function

Function UniqueRandom(ByVal numRows As Long, ByVal a As Long, ByVal b As 
Long) As Long()
Dim i As Long, j As Long, x As Long

ReDim arr(b - a) As Long

Randomize
For i = 0 To b - a:    arr(i) = a + i:     Next
If b - a < count Then UniqueRandom = arr:    Exit Function

For i = 0 To b - a    'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i):   arr(i) = arr(j):   arr(j) = x    ' swap
Next

' After shuffling the array, we can simply take the first portion

If numRows = 0 Then
ReDim Preserve arr(0)
Else
ReDim Preserve arr(0 To numRows - 1)
 On Error Resume Next
End If
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
  If arr(j) < arr(i) Then x = arr(i):   arr(i) = arr(j):   arr(j) = x   ' 
swap
Next
Next

UniqueRandom = arr
End Function

多个Excel工作表中的随机行选择

2 个答案: