Randomize VBA Code

[Evie76]

Hi

Below is a VBA code I have come across that selects records at random. This does everything I need it to do for the project I have been tasked with, however this code highlights the records that have been selected. How do I change it so that it no longer highlights.

Private Sub cmdPickRandom_Click()

Dim lLastRow As Long

wksHome.AutoFilterMode = False

If Trim(txtRandomCount.Text) = "" Or IsNumeric(txtRandomCount.Text) = False Then
MsgBox "All data showing", vbInformation
Exit Sub
End If

If txtRandomCount.Text <= 0 Then
MsgBox "Invalid sample numbers to be picked", vbInformation
Exit Sub
End If

If CInt(txtRandomCount.Text) <> txtRandomCount.Text Then
MsgBox "Invalid sample numbers to be picked", vbInformation
Exit Sub
End If

lLastRow = wksHome.Range("C" & Rows.Count).End(xlUp).Row

If lLastRow < 19 Then
MsgBox "It seems there is no data in the sheet" & vbNewLine & vbNewLine & "Note: Column C of the Home sheet should not have empty cells", vbInformation
Exit Sub
End If

If txtRandomCount.Text > lLastRow - 18 Then
MsgBox "Number of records to be picked cannot be greater than total records available in the sheet.", vbInformation
Exit Sub
End If

Application.ScreenUpdating = False

'Clear old formulas
wksHome.Range("A:B").ClearContents

'Clear formatting
With wksHome.Range("19:" & Rows.Count).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

'Add SN
wksHome.Range("A19").Value = "=A18+1"

'Copy formula
wksHome.Range("A19").Copy wksHome.Range("A19:A" & lLastRow)

'Random formula
wksHome.Range("B19").Value = "=RANDBETWEEN(1," & lLastRow - 18 & ")"

'Copy formula
wksHome.Range("B19").Copy wksHome.Range("B19:B" & lLastRow)

'Calculate Formula
wksHome.Calculate

'Convert to value
wksHome.Range("A19:B" & lLastRow).Value = wksHome.Range("A19:B" & lLastRow).Value

'Sort the data by Random number
wksHome.Sort.SortFields.Clear
wksHome.Sort.SortFields.Add Key:=wksHome.Range("B19:B" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wksHome.Sort
.SetRange wksHome.Range(wksHome.Cells(18, 1), wksHome.Cells(lLastRow, wksHome.Cells.SpecialCells(xlCellTypeLastCell).Column))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Color sample records
wksHome.Range("19:" & CInt(txtRandomCount.Text) + 18).Interior.Color = vbGreen

'Sort the data by SN
wksHome.Sort.SortFields.Clear
wksHome.Sort.SortFields.Add Key:=wksHome.Range("A19:A" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wksHome.Sort
.SetRange wksHome.Range(wksHome.Cells(18, 1), wksHome.Cells(lLastRow, wksHome.Columns.Count))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Clear formulas
wksHome.Range("A:B").ClearContents

wksHome.AutoFilterMode = False
wksHome.Range("18:" & lLastRow).AutoFilter
wksHome.Range(wksHome.Cells(18, 1), wksHome.Cells(lLastRow, wksHome.Columns.Count)).AutoFilter Field:=3, Criteria1:=RGB(0, 255, 0), Operator:=xlFilterCellColor

Application.ScreenUpdating = True

MsgBox "Done", vbInformation

Unload Me

End Sub


I am currently using Office 365

Many thanks

Evie

[TMS]

If you don't highlight, how do you know what has been picked?


Administrative Note:

Welcome to the forum.

We would very much like to help you with your query, however you need to include code tags around your code.

Please take a moment to add the tags. Posting code between tags makes your code much easier to read and copy for testing, and it also maintains VBA formatting.

Please see Forum Rule #2 about code tags and adjust accordingly. Click on Edit to open your post, then highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

(Note: this change is not optional.)

[Evie76]

It filters down the list once you have selected the amount of records you require then brings the records upto the top

[Evie76]

I have attached a sample workbook so that you know what I am getting at

[jeffreybrown]

As soon as you comply with post #2, somebody may be able to help.