Random row selection in multiple excel sheets - vba

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

Answer 1

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

Answer 2

Since QHarr's code needed to have all worksheet names should exist in the workbook did not work for me in the end. But with merging it some other project's function i made it work.
Opens an output xlsx file in same folder,
Index&Match to find the random rows amount
loop through all sheets with random function
then paste all randomized rows into Sheet named RASSAL
It may be unefficient since I really dont have much info on codes, but guess i managed to modify it into my needs.
Open to suggestions anyway and thanks to #QHarr very much for His/Her replies.
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