Random row selection in multiple excel sheets

Question

I have an output excel file from another macro which has multiple sheets (named 100,101,102... etc.) Sheet numbers will vary depending on prior macro's output.

Also there is a sheet named sheet1 which has info about how many random rows should be selected from 100,101,102... etc.

I tried to merge/combine what i could find from similar macros but i guess the loop part is way over my head.

I will run the macro from another "main" excel. which will open related output xls.

Then it will lookup for random rows amount from sheet1 and then select that number of random rows in related sheet and move to next sheet. (I'm getting the correct amount from lookup (used index match))

But for randomized part i was not able to make it work for multiple sheets.

It does not matter if it selects and colors the rows or copies and pastes them to another sheet/wb. Both is ok, but I need to automate this process since i have so much data waiting.

The macro i have managed so far is below, since I'm a newbie there may be unrelated or unnecessary things.

Is it possible?

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

QHarr · Accepted Answer

Here is an example (i have integrated some code, adapted from other places, and added the references in to the code itself) I would welcome feedback from other users and can refine.

Sheet1 has the number of rows to return and the sheet names (i have used a short list)

The other sheets have some random data e.g. Sheet2

The code reads the sheet names into one array and the number of rows to randomly choose from each sheet into another array.

It then loops the sheets, generates the number of required random rows by selecting between the first and the start row in the sheet (this currently doesn't have error handling in case specified number of random rows exceeds available number ,but then could set numRows to lastRow. Union is used to collect these for the given sheet and they are copied to the next available row in the target sheet of another workbook. Union can't be used across worksheets sadly so a workaround has to be found, i chose this copy for each worksheet.

I have made some assumptions about where to copy from and to but have a play. I have also left some of your code in and currently set mnv = ThisWorkbook and the workbook to copy to is called otherWorkbook. Yours may be differently named and targeted but this was aimed at showing you a process for generating numbers and copying them in a loop.

Have used a function by Rory to test if the worksheet exists.

Example result:

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

Random row selection in multiple excel sheets

Answers (2)

Related Questions