0

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
braX
  • 11,506
  • 5
  • 20
  • 33
scg
  • 11
  • 4
  • How are you generating your random row selection? I was expecting to see a randomize (so don't re-select prior number) with a randbetween (using boundaries of range rows start and end) to generate individual row numbers and perhaps a Union to collect these together into one range variable to copy. – QHarr Dec 19 '17 at 14:16
  • Generally, use Long rather than Integer variables. – QHarr Dec 19 '17 at 14:18
  • Im not sure I get this right so I'll sum it up: You want to loop through all worksheets in your workbook and copy a number of rows from each sheet to another sheet. The number is supposed to be a randomized number for each sheet. If that's the case, is it okay to generate that random number within this macro rather then getting it from the other sheet? – Chrowno Dec 19 '17 at 14:26
  • I'm guessing you are picking up a different number of random rows from each sheet according to what is in the range you are reading from i.e. that range specifies how many rows to collect from each sheet? Is col D holding the sheet names and col S holding the number of rows to copy? – QHarr Dec 19 '17 at 14:47
  • @Qharr-> I could not make it work in any way and randomize parts of the code was always getting errors so i removed. I'll keep Long variables in mind. And for your last comment, yes you are right. Col D has Account numbers, Col S has how many samples to be selected for each account, worksheet names are also account numbers and each sheet consists of transactions related to that account only. @Chrowno-> Number of random selections are set with some other work done priorly, not generated.For other part yes you summed it up perfectly. :) – scg Dec 19 '17 at 19:51

2 Answers2

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)

number of randomly chosen rows to return and worksheet to select from

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

Sheet 2 example data

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:

9 random rows selected in total with number from each sheet as specified.

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
QHarr
  • 83,427
  • 12
  • 54
  • 101
  • Thanks for response, I'm getting runtime error 9 for line 'Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))' Even tried with mvn-mnv difference but could not make it work. For error checking part, number of random selections are made in line with number of transactions, so random selection number can be equal to row numbers at max. – scg Dec 19 '17 at 19:53
  • The error is saying it can't find that sheet. Are the sheetnames in the following range ? worksheetNames = SampleS.Range("$D$1:$D$3") AND is SampleS in the correct workbook? If you put a breakpoint at the line after this (the code i just mentioned) and look in the locals window it will tell you what is in the array worksheetNames. – QHarr Dec 19 '17 at 20:21
  • Ok, My Range was "$D$1:$D$304" and it has some headers and empty cells. Guess that caused the error. Modified it to "$D$8:$D$304" and now im getting the same error (runtime 9) at line **Set currRow = currSheet.Cells.Rows(iArr(i))**. Also my Sheet1 col D has all the possible account numbers in it, but mvn workbook has sheets those only exists in a specific case. eg. 106 sheets in mvn but range in col D has 297 cells. will this cause an error? – scg Dec 20 '17 at 08:17
  • And while it gives the error above, i get output at otherworkbook for only 1 loop. But output is related to 100th sheet's random selection (which is 730) . My first sheet is named 100. I think it takes the name and then goes to 100th sheet and does random selection. – scg Dec 20 '17 at 08:26
  • Yes. It picks up each sheet name which is listed in D8:D304 (in your edited code) and will go to the sheet in D8 and copy the number of rows listed in S8 from that sheet, it will go to the sheet listed in D9 and take the number of rows listed in S9 from that sheet etc.........The principle is column D says which sheet to visit, and column S says how many rows to pick randomly from that sheet. The array worksheetNames should only have worksheet names in it and no blanks and those worksheet names should all exist in the workbook where it will be copying rows from – QHarr Dec 20 '17 at 08:38
0

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
scg
  • 11
  • 4