Solved How to select a fixed number of random rows in VBA

August 23, 2017 at 04:12:35
Specs: Windows 7
I have a VB script that will randomly select 20% of rows in a worksheet. and paste to a new worksheet. I want to change this to show a fixed number of rows (say 5). Additionally, my script will include the header when selecting a random row, i need to amend this to exclude the first row (Header). It currently looks as follows

Sub MacroFILTER6()

' MacroFILTER6 Macro
Dim strInput As String
Sheets("Customer Accounts").Select
strInput = InputBox("Enter date which you require a random sample for. Date to be entered in DD/MM/YYYY format. Where you see prompt to confirm deletion of tab, please hit OK")
Selection.AutoFilter
Sheets("Customer Accounts").Range("A:R").AutoFilter Field:=17, Criteria1:= _
strInput
Cells.Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Select
ActiveSheet.Name = "TempExtract"
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Select
ActiveSheet.Name = "Extractpercentage"
Sheets("TempExtract").Select
Range("A1").Select
ActiveSheet.Paste
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 Customer_Accounts Column A
numRows = Sheets("TempExtract").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 Sheet5
For copyRow = 1 To percRows
Sheets("TempExtract").Rows(MyRows(copyRow)).EntireRow.Copy _
Destination:=Sheets("Extractpercentage").Range("A2")(copyRow, 1)
Next
'Copy header row to newly created extract
Sheets("Customer Accounts").Select
Rows("1:1").Select
Selection.Copy
Sheets("Extractpercentage").Select
Range("1:1").Select
ActiveSheet.Paste
'Delete Temp Extract Sheet as no longer required
Sheets("TempExtract").Select
ActiveWindow.SelectedSheets.Delete
'Rename Exctract percentage with date and time it was created.
Sheets("Extractpercentage").Select
Sheets("Extractpercentage").Name = _
WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss am/pm")
'Autofit columns
Cells.Select
Selection.ColumnWidth = 60
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
End Sub


See More: How to select a fixed number of random rows in VBA

Reply ↓  Report •

✔ Best Answer
August 25, 2017 at 01:09:19
Would just like to share a solution provided on another forum.

Option Explicit

Sub GenerateRandomSample()
  Static sDate As String, sName As String
  Dim dDate As Date
  Dim Data, Possible, This
  Dim i As Long, j As Long
  Dim Ws As Worksheet
  Static Amount As Long
  Dim SheetName As String
  
  'Get a valid user input
  Do
    sDate = InputBox("Enter date", "Generate Random Sample", sDate)
    If sDate = "" Then Exit Sub
    If Not IsDate(sDate) Then Beep
  Loop Until IsDate(sDate)
  dDate = sDate
  sName = InputBox("Enter name", "Generate Random Sample", sName)
  If sName = "" Then Exit Sub
  If Amount = 0 Then
    Amount = 5 'Default
  Else
    Amount = Amount + 1 'Adjust from last call (see code below)
  End If
  Amount = Application.InputBox("Enter amount", "Generate Random Sample", Amount, Type:=1)
  If Amount <= 0 Then Exit Sub
  
  'Read in all data
  Data = Sheets("Customer Accounts").Range("A1").CurrentRegion.Value
  'Initialize
  Amount = Amount - 1
  Possible = Array()
  j = -1
  'Collect all row numbers that are possible
  For i = 2 To UBound(Data)
    If (Data(i, 17) = dDate) And (Data(i, 18) = sName) Then
      j = j + 1
      ReDim Preserve Possible(0 To j)
      Possible(j) = i
    End If
  Next
  'Found any?
  If j < 0 Then
    MsgBox "No match found for " & dDate & " - " & sName, vbExclamation, "Generate Random Sample"
    Exit Sub
  End If
  'More than 5?
  If j > Amount Then
    'Get 5 random rows of the possible rows
    Randomize
    ReDim This(0 To Amount)
    For i = 0 To Amount
      This(i) = Possible(RandomUnique(0, j, i = 0))
    Next
  Else
    'Just this
    This = Possible
  End If
  'Copy the rows to the top
  For i = 0 To UBound(This)
    For j = 1 To UBound(Data, 2)
      Data(i + 2, j) = Data(This(i), j)
    Next
  Next
  
  'Output
  SheetName = NewSheetName(sName & " " & Format(dDate, "dd/mm/yyyy"))
  Set Ws = Worksheets.Add(After:=Sheets(Sheets.Count))
  Ws.Range("A1").Resize(UBound(This) + 2, UBound(Data, 2)).Value = Data
  Ws.Name = SheetName
End Sub

Private Function RandomUnique(ByVal Lo As Long, ByVal Hi As Long, _
    Optional Reset As Boolean = False) As Long
  Static Dict As Object 'Dictionary
  'Init dictionary if necessary
  If Dict Is Nothing Then Set Dict = CreateObject("Scripting.Dictionary")
  'Remove all used numbers if forced from outside
  If Reset Then Dict.RemoveAll
  Do
    'Get a random number
    RandomUnique = Int((Hi - Lo + 1) * Rnd) + Lo
    'Already used?
  Loop Until Not Dict.Exists(RandomUnique)
  'Remember it
  Dict.Add RandomUnique, 0
  'Automatic reset if all numbers used
  If Dict.Count > Hi - Lo Then Dict.RemoveAll
End Function

Private Function ValidSheetName(ByVal SheetName As String) As String
  'Removes invalid chars from Sheetname
  Const InvalidChars = ":\/?*[]"
  Dim i As Integer
  For i = 1 To Len(InvalidChars)
    SheetName = Replace(SheetName, Mid(InvalidChars, i, 1), "")
  Next
  ValidSheetName = Mid(SheetName, 1, 31)
End Function

Private Function SheetExists(ByVal SheetNameOrIndex As Variant, _
    Optional ByVal Wb As Workbook = Nothing) As Boolean
  'True if sheet SheetNameOrIndex exists
  On Error Resume Next
  If Wb Is Nothing Then Set Wb = ActiveWorkbook
  SheetExists = Not Wb.Sheets(SheetNameOrIndex) Is Nothing
End Function

Private Function NewSheetName(ByVal SheetName As String, _
    Optional ByVal Wb As Workbook = Nothing) As String
  'Returns a non existing sheet name that begins with SheetName
  Dim i As Long, LeftParen As Long
  Dim NewName As String, SheetExt As String, Blank As String
  SheetName = ValidSheetName(SheetName)
  NewName = SheetName
  If Wb Is Nothing Then Set Wb = ActiveWorkbook
  If SheetExists(SheetName, Wb) Then
    LeftParen = InStrRev(SheetName, "(")
    Blank = " "
    If LeftParen Then
      If SheetName Like "*(" & String(Len(SheetName) - LeftParen - 1, "#") & ")" Then
        i = Mid$(SheetName, LeftParen + 1, Len(SheetName) - LeftParen - 1)
        SheetName = Left$(SheetName, LeftParen - 1)
        Blank = ""
      End If
    End If
    Do
      i = i + 1
      SheetExt = Blank & "(" & i & ")"
      If Len(SheetName) + Len(SheetExt) > 31 Then
        SheetName = Mid(SheetName, 1, 31 - Len(SheetExt))
        If Len(SheetExt) = 31 Then
          'If this happens, then you do extraordinary things, _
            and should better take GUIDs as sheet names. ;-)
          Err.Raise 6, "NewSheetName"
        End If
      End If
      NewName = SheetName & SheetExt
    Loop Until Not SheetExists(NewName, Wb)
  End If
  NewSheetName = NewName
End Function



#1
August 23, 2017 at 05:50:53
Please click on the How-To link at the end of this post and read the instructions on how to post VBA code in this forum so that it is easier for us to read. Then edit/repost your code so that it looks similar to the example found via that link. Thanks!

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#2
August 23, 2017 at 06:20:36
Sub MacroFILTER6()

' MacroFILTER6 Macro
Dim strInput As String
Sheets("Customer Accounts").Select
strInput = InputBox("Enter date which you require a random sample for. Date to be entered in DD/MM/YYYY format. Where you see prompt to confirm deletion of tab, please hit OK")
Selection.AutoFilter
Sheets("Customer Accounts").Range("A:R").AutoFilter Field:=17, Criteria1:= _
strInput
Cells.Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "TempExtract"
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "Extractpercentage"
    Sheets("TempExtract").Select
    Range("A1").Select
    ActiveSheet.Paste
  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 Customer_Accounts Column A
  numRows = Sheets("TempExtract").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 Sheet5
  For copyRow = 1 To percRows
   Sheets("TempExtract").Rows(MyRows(copyRow)).EntireRow.Copy _
    Destination:=Sheets("Extractpercentage").Range("A2")(copyRow, 1)
    Next
  'Copy header row to newly created extract
    Sheets("Customer Accounts").Select
    Rows("1:1").Select
    Selection.Copy
    Sheets("Extractpercentage").Select
    Range("1:1").Select
    ActiveSheet.Paste
    'Delete Temp Extract Sheet as no longer required
    Sheets("TempExtract").Select
    ActiveWindow.SelectedSheets.Delete
    'Rename Exctract percentage with date and time it was created.
    Sheets("Extractpercentage").Select
    Sheets("Extractpercentage").Name = _
    WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss am/pm")
    'Autofit columns
    Cells.Select
    Selection.ColumnWidth = 60
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
End Sub





Reply ↓  Report •

#3
August 23, 2017 at 07:26:41
It would take a lot of effort to set up a workbook to test my following suggestions, so I am going to leave it to you to test. It may work fine or it may not, there may even be syntax errors. Try my suggestions and we'll take it from there.

re: "I want to change this to show a fixed number of rows (say 5)."

The following snippet is the section that determines the number of rows to extract. The comments preceding the instructions explain what each instruction is doing. If you want to extract a fixed number, you'll need to eliminate the instructions related to determining and using the percentage variable (percRow) and replace them with instructions to use a fixed number (5)

Change this...

'Determine Number of Rows in Customer_Accounts Column A
  numRows = Sheets("TempExtract").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

...to this:


'Determine Number of Rows in Customer_Accounts Column A
  numRows = Sheets("TempExtract").Range("A" & Rows.Count).End(xlUp).Row
'Allocate 5 elements in Array
    ReDim MyRows(5)
'Create 5 Random numbers and fill array
     For nxtRow = 1 To 5

Further down, there is a snippet that actually copies the rows. That needs to be changed also.

Change this...

'Loop through Array, copying rows to Sheet5
  For copyRow = 1 To percRows

...to this:

'Loop through Array, copying rows to Sheet5
  For copyRow = 1 To 5

re: "Additionally, my script will include the header when selecting a random row, i need to amend this to exclude the first row (Header)"

The following snippet is the section that checks for duplicate random numbers immediately after each random row number is generated. You'll need to add a check to see if the random number generator returned 1. If it does, tell the code to create a new random number.

Change this...

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

...to this:


getNew:
'Generate Random number
      nxtRnd = Int((numRows) * Rnd + 1)
'Check for Header Row number (1)
      If nxtRnd =1 then GoTo getNew
'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

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

Related Solutions

#4
August 23, 2017 at 07:34:54
Thanks Derby Dad, that looks great. I'll give it all bash and see how pans out. I only first looked at VB last Friday, the break down and simple explanation you have given has been perfect. Thanks and i will report back as to its success.

Reply ↓  Report •

#5
August 23, 2017 at 07:46:50
OK - quick run through and mostly worked well. Ran it 4 times and on each occasion it provided a different volume of outputs, where the code requests 5 random rows, i received, 5, then 4 then 3 then 6 on the 4 occasions i ran the script.

Just to complicate things further, if in addition to having to enter a date, would it be possible to also have a request for name. for filter purposes this would be in column 18 of the same spreadsheet that the date is looking up.


Reply ↓  Report •

#6
August 23, 2017 at 10:09:50
re: "Ran it 4 times and on each occasion it provided a different volume of outputs, where the code requests 5 random rows, i received, 5, then 4 then 3 then 6 on the 4 occasions i ran the script."

There must be something else going in your full code vs. the "random rows" snippets that I modified. The following short version does nothing more than copy 5 random rows to Sheet(2) from a Sheet(1) data set of 400 rows (plus a header row). I only tested the parts of the macro that required modification from a "percentage" basis to a fixed number (5).

I set up my workbook to watch Sheet(2) and clicked the run button until my finger was sore. Well over 100 times. The macro returned 5 random numbers every single time

Sheet 1 (Input) 
        A
1     Header
2      1
3      2
4      3
5      4
....
401   400


Sheet 2 (Output Example) 
       A
1         
2     337
3     164
4     290
5     163
6     264

Here is the code I tested:

Sub Short_MacroFILTER6()

Dim MyRows() As Integer    ' Declare dynamic array.
Dim numRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer

'Determine Number of Rows in Sheet(1)Column A
  numRows = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
'Allocate 5 elements in Array
    ReDim MyRows(5)

'Create Random numbers and fill array
     For nxtRow = 1 To 5
getNew:
'Generate Random number
      nxtRnd = Int((numRows) * Rnd + 1)
'Check for Header Row number (1)
      If nxtRnd = 1 Then GoTo getNew
'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 Sheet5
  For copyRow = 1 To 5
   Sheets(1).Rows(MyRows(copyRow)).EntireRow.Copy _
    Destination:=Sheets(2).Range("A2")(copyRow, 1)
  Next
  
End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#7
August 23, 2017 at 10:15:06
Wait a minute....

How could you possibly have gotten 6 rows when the loops only go to 5 and the array only has 5 elements in it?

I'm reluctant to use the word "impossible" from this far away, but I can't imagine any way for the modifications I made to output 6 rows.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#8
August 23, 2017 at 23:53:29
Hi, thanks for looking at this. Back in work and will play about with this again this morning using most recent code and ensuring no other issues to trip it up.

Reply ↓  Report •

#9
August 24, 2017 at 00:21:18
Reviewed code and seen that i still had percRow showing in the following line

Dim numRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer

I have removed it, re ran code and works with 5 outputs on every occasion.

Having thought about this overnight, I've had an idea of how I can make the workbook more efficient and hoping further support may be available.

This task will look at the work carried out by several people. The filter on the date is so that a random check can be made of work completed that day. The drawback is that it means that its nor a fair split across individuals. If i have staff name (Staff1, Staff2, Staff3) in column 18 (adjacent to the date column) is there a way to output 5 random rows for each unique staff name in column 18?

Therefore if there was only one staff completing work for that day, it will out put 5 random rows, if 4 people working that day, then it will output 20 random rows (4*5).

If it makes it easier I can have a table that lists staff name in with in Sheet1 A:A with desired number of outputs for each staff adjacent in column B:B

	A	                      B
1	Staff name	desired vol outputs
2	Staff1	                      4
3	Staff2	                      4
4	Staff3	                      6
5	Staff4	                      6

This would actually be beneficial as would allow a manager to vary random sampled volumes dependent on quality of past work.

Thanks in advance.


Reply ↓  Report •

#10
August 24, 2017 at 04:06:42
re: "Reviewed code and seen that i still had percRow showing in the following line

Dim numRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer

That wasn't the problem. The only thing that line does is dimension the variables so that VBA knows that they might be used. Unless they are actually used in an instruction that have no impact on the running of the code.

It's like buying hot pepper for a recipe but never putting it in the mix. It won't change the flavor of the food just by sitting on the shelf. Something else was causing the variable output. If you didn't change anything else, I wouldn't be surprised if your problem came back.

I don't have time to look at the rest of your post until later.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#11
August 24, 2017 at 05:08:46
I have been running the report all morning with amendments to try and incorporate additional search criteria and so far has always been outputting the 5 i have requested. Fingers crossed that bit has resolved itself.

Regards the rest of what i am trying to do. i have a first attempt but it will only provide a random sample based on a pre-specified date and staff name. If i could improve on this so that i get all staff for specified date by inputting date into prompt box rather than cell before starting macro i think i may wet my pants with excitement.
Worksheet ("Workload Tracker")

                Column    Column
                     D	       E
		
Row 48	Staff2	23/09/2017

Macro script

Sub dualfilterplusstaff()

'Create sheets that will be required for processing
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "dateextract"
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "finalextract"
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Select
    ActiveSheet.Name = "staffextract"

' Filter completed work (Customer Accounts sheet) by name and copy
    Dim strInput As String
    Sheets("Customer Accounts").Select
    strInput = Sheets("Workload Tracker").Range("D48")
    Selection.AutoFilter
    Sheets("Customer Accounts").Range("A:S").AutoFilter Field:=18, Criteria1:= _
    strInput
    Cells.Select
    Selection.Copy
    
'Paste the filtered completed work to staffextract
    Sheets("staffextract").Select
    Range("A1").Select
    ActiveSheet.Paste
       
' Filter staffextract by date and copy
    
    Sheets("staffextract").Select
    strInput = Sheets("Workload Tracker").Range("E48")
    Selection.AutoFilter
    Sheets("staffextract").Range("A:S").AutoFilter Field:=17, Criteria1:= _
    strInput
    Cells.Select
    Selection.Copy

'Paste to dateextract
    Sheets("dateextract").Select
    Range("A1").Select
    ActiveSheet.Paste

'randomly select rows from staffextract

    Randomize 'Initialize Random number seed
    Dim MyRows() As Integer    ' Declare dynamic array.
    Dim numRows, nxtRow, nxtRnd, chkRnd, copyRow As Integer

'Determine Number of Rows in staffextract Column A
    numRows = Sheets("dateextract").Range("A" & Rows.Count).End(xlUp).Row

'Allocate 5 elements in Array
    ReDim MyRows(5)

'Create 5 Random numbers and fill array
    For nxtRow = 1 To 5
getNew:

'Generate Random number
    nxtRnd = Int((numRows) * Rnd + 1)

'Check for Header Row number (1)
    If nxtRnd = 1 Then GoTo getNew

'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 finalextract
    For copyRow = 1 To 5
    Sheets("dateextract").Rows(MyRows(copyRow)).EntireRow.Copy _
    Destination:=Sheets("finalextract").Range("A2")(copyRow, 1)
        Next

'Copy header row to newly created extract
    Sheets("Customer Accounts").Select
    Rows("1:1").Select
    Selection.Copy
    Sheets("finalextract").Select
    Range("1:1").Select
    ActiveSheet.Paste
    
'Delete dateextract Sheet as no longer required
    Sheets("dateextract").Select
    ActiveWindow.SelectedSheets.Delete
    
'Delete staffextract Sheet as no longer required
    Sheets("staffextract").Select
    ActiveWindow.SelectedSheets.Delete
    
'Rename finalextract with date / time it was created and staff name
    Sheets("finalextract").Select
    Sheets("finalextract").Name = _
    WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss am/pm")
    
'Autofit columns
    Cells.Select
    Selection.ColumnWidth = 60
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
End Sub


Reply ↓  Report •

#12
August 24, 2017 at 06:50:59
First, allow me to offer a suggestion unrelated to your question...

Rarely do you need to Select an object in VBA in order to perform an operation on it. You can reference the object directly with the operation. Anything that looks like this...

   Sheets.Add After:=Sheets(Sheets.Count)
     ActiveSheet.Select
      ActiveSheet.Name = "dateextract"

...can be replaced with this:

   Sheets.Add After:=Sheets(Sheets.Count)
     ActiveSheet.Name = "dateextract"

Things like this...

Cells.Select
    Selection.Copy

'Paste to dateextract
    Sheets("dateextract").Select
    Range("A1").Select
    ActiveSheet.Paste

...can be replaced with this:

Cells.Copy

'Paste to dateextract
    Sheets("dateextract").Paste

This...

'Autofit columns
    Cells.Select
    Selection.ColumnWidth = 60
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit

...could be this:

'Autofit columns
    With Cells
      .ColumnWidth = 60
      .EntireRow.AutoFit
      .EntireColumn.AutoFit
    End With

If you remove the "Selection" instructions, your code will not only be more efficient, but a lot easier to read and follow. In addition, since you do not have ScreenUpdating disabled, I assume that your workbook is moving all around with every Selection/Copy/Paste operation. Eliminating the .Select instructions will prevent a lot of that.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#13
August 24, 2017 at 06:56:15
Good pointers, thank you. As i hadn't used VBA until Friday, i have been learning rapidly. Tips like that are great.

Reply ↓  Report •

#14
August 24, 2017 at 06:57:01
I haven't come across screen updating. no idea what it is sorry.

Reply ↓  Report •

#15
August 24, 2017 at 07:07:05
Application.ScreenUpdating = False

This stops Excel from displaying the changes that the code is making while it is running. VBA does everything in the background and then when it is all done the workbook basically gets updated in one action.

Even with Application.ScreenUpdating = False, you can still monitor the changes when using F8 to Single Step through the code. It is only disabled when the code is running on it's own.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Reply ↓  Report •

#16
August 24, 2017 at 07:17:48
Ah, i have been using F8 to step through the code to see changes and identify source of issues.

Reply ↓  Report •

#17
August 25, 2017 at 01:09:19
✔ Best Answer
Would just like to share a solution provided on another forum.

Option Explicit

Sub GenerateRandomSample()
  Static sDate As String, sName As String
  Dim dDate As Date
  Dim Data, Possible, This
  Dim i As Long, j As Long
  Dim Ws As Worksheet
  Static Amount As Long
  Dim SheetName As String
  
  'Get a valid user input
  Do
    sDate = InputBox("Enter date", "Generate Random Sample", sDate)
    If sDate = "" Then Exit Sub
    If Not IsDate(sDate) Then Beep
  Loop Until IsDate(sDate)
  dDate = sDate
  sName = InputBox("Enter name", "Generate Random Sample", sName)
  If sName = "" Then Exit Sub
  If Amount = 0 Then
    Amount = 5 'Default
  Else
    Amount = Amount + 1 'Adjust from last call (see code below)
  End If
  Amount = Application.InputBox("Enter amount", "Generate Random Sample", Amount, Type:=1)
  If Amount <= 0 Then Exit Sub
  
  'Read in all data
  Data = Sheets("Customer Accounts").Range("A1").CurrentRegion.Value
  'Initialize
  Amount = Amount - 1
  Possible = Array()
  j = -1
  'Collect all row numbers that are possible
  For i = 2 To UBound(Data)
    If (Data(i, 17) = dDate) And (Data(i, 18) = sName) Then
      j = j + 1
      ReDim Preserve Possible(0 To j)
      Possible(j) = i
    End If
  Next
  'Found any?
  If j < 0 Then
    MsgBox "No match found for " & dDate & " - " & sName, vbExclamation, "Generate Random Sample"
    Exit Sub
  End If
  'More than 5?
  If j > Amount Then
    'Get 5 random rows of the possible rows
    Randomize
    ReDim This(0 To Amount)
    For i = 0 To Amount
      This(i) = Possible(RandomUnique(0, j, i = 0))
    Next
  Else
    'Just this
    This = Possible
  End If
  'Copy the rows to the top
  For i = 0 To UBound(This)
    For j = 1 To UBound(Data, 2)
      Data(i + 2, j) = Data(This(i), j)
    Next
  Next
  
  'Output
  SheetName = NewSheetName(sName & " " & Format(dDate, "dd/mm/yyyy"))
  Set Ws = Worksheets.Add(After:=Sheets(Sheets.Count))
  Ws.Range("A1").Resize(UBound(This) + 2, UBound(Data, 2)).Value = Data
  Ws.Name = SheetName
End Sub

Private Function RandomUnique(ByVal Lo As Long, ByVal Hi As Long, _
    Optional Reset As Boolean = False) As Long
  Static Dict As Object 'Dictionary
  'Init dictionary if necessary
  If Dict Is Nothing Then Set Dict = CreateObject("Scripting.Dictionary")
  'Remove all used numbers if forced from outside
  If Reset Then Dict.RemoveAll
  Do
    'Get a random number
    RandomUnique = Int((Hi - Lo + 1) * Rnd) + Lo
    'Already used?
  Loop Until Not Dict.Exists(RandomUnique)
  'Remember it
  Dict.Add RandomUnique, 0
  'Automatic reset if all numbers used
  If Dict.Count > Hi - Lo Then Dict.RemoveAll
End Function

Private Function ValidSheetName(ByVal SheetName As String) As String
  'Removes invalid chars from Sheetname
  Const InvalidChars = ":\/?*[]"
  Dim i As Integer
  For i = 1 To Len(InvalidChars)
    SheetName = Replace(SheetName, Mid(InvalidChars, i, 1), "")
  Next
  ValidSheetName = Mid(SheetName, 1, 31)
End Function

Private Function SheetExists(ByVal SheetNameOrIndex As Variant, _
    Optional ByVal Wb As Workbook = Nothing) As Boolean
  'True if sheet SheetNameOrIndex exists
  On Error Resume Next
  If Wb Is Nothing Then Set Wb = ActiveWorkbook
  SheetExists = Not Wb.Sheets(SheetNameOrIndex) Is Nothing
End Function

Private Function NewSheetName(ByVal SheetName As String, _
    Optional ByVal Wb As Workbook = Nothing) As String
  'Returns a non existing sheet name that begins with SheetName
  Dim i As Long, LeftParen As Long
  Dim NewName As String, SheetExt As String, Blank As String
  SheetName = ValidSheetName(SheetName)
  NewName = SheetName
  If Wb Is Nothing Then Set Wb = ActiveWorkbook
  If SheetExists(SheetName, Wb) Then
    LeftParen = InStrRev(SheetName, "(")
    Blank = " "
    If LeftParen Then
      If SheetName Like "*(" & String(Len(SheetName) - LeftParen - 1, "#") & ")" Then
        i = Mid$(SheetName, LeftParen + 1, Len(SheetName) - LeftParen - 1)
        SheetName = Left$(SheetName, LeftParen - 1)
        Blank = ""
      End If
    End If
    Do
      i = i + 1
      SheetExt = Blank & "(" & i & ")"
      If Len(SheetName) + Len(SheetExt) > 31 Then
        SheetName = Mid(SheetName, 1, 31 - Len(SheetExt))
        If Len(SheetExt) = 31 Then
          'If this happens, then you do extraordinary things, _
            and should better take GUIDs as sheet names. ;-)
          Err.Raise 6, "NewSheetName"
        End If
      End If
      NewName = SheetName & SheetExt
    Loop Until Not SheetExists(NewName, Wb)
  End If
  NewSheetName = NewName
End Function


Reply ↓  Report •

Ask Question