Extracting number from a range

Goalexcel

Board Regular
Joined
Dec 28, 2020
Messages
95
Office Version
  1. 2016
Platform
  1. Windows
Hello Experts, Thank you for your assistance. I am not expert in VBA , Can you kindly modified the VBA code that previously I got in this forum on january 2021. Here is the pic of the result
1628746795665.png
Sub Pick_N_v2()
Dim d As Object
Dim a As Variant, b As Variant, Results As Variant
Dim c As Long, i As Long, k As Long, ShNum As Long, PicksMade As Long, NumsLeft As Long
Dim PickHowMany As Long, Rws As Long, Cols As Long, NextClr As Long, ResultsHeaderRow As Long

Randomize
Set d = CreateObject("Scripting.Dictionary")
For ShNum = 1 To 5
With Sheets(ShNum)
Application.Goto Reference:=.Range("A1"), Scroll:=True
Rws = .Range("A1").End(xlDown).Row - 1
Cols = .Cells(1, Columns.Count).End(xlToLeft).Column
ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
PicksMade = .Range("A" & ResultsHeaderRow).CurrentRegion.Rows.Count - 1
If PicksMade > 0 Then
b = .Range("A" & ResultsHeaderRow + 1).Resize(PicksMade, Cols).Value
NextClr = .Range("A" & Rows.Count).End(xlUp).Interior.ColorIndex + 2
Else
NextClr = 4
End If
NumsLeft = Rws - PicksMade
Do
PickHowMany = Application.InputBox("Pick how many numbers? (Max = " & NumsLeft & ")", .Name, IIf(NumsLeft > 3, 3, NumsLeft), , , , , 1)
Loop Until PickHowMany <= NumsLeft
If PickHowMany > 0 Then
With .Range("A2").Resize(Rws, Cols)
a = .Value
ReDim Results(1 To PickHowMany, 1 To Cols)
For c = 1 To UBound(a, 2)
d.RemoveAll
For i = 1 To Rws
d(a(i, c)) = i
Next i
If PicksMade > 0 Then
For i = 1 To PicksMade
d.Remove b(i, c)
Next i
End If
For i = 1 To PickHowMany
k = 1 + Int(Rnd() * d.Count)
Results(i, c) = d.Keys()(k - 1)
.Cells(d.Items()(k - 1), c).Interior.ColorIndex = NextClr
d.Remove Results(i, c)
Next i
Next c
End With
With .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PickHowMany, UBound(Results, 2))
.Select
.Value = Results
.Interior.ColorIndex = NextClr
End With
Else
MsgBox "Zero picks chosen. Sheet '" & .Name & "' has been skipped"
End If
End With
Next ShNum
Application.ScreenUpdating = True
End Sub
Here is the excel file finished and modified, will be good if the numbers go in the row 45
Please see file
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,268
It probably would have been better if you had inserted this request at the end of the original discussion (Extracting number from a range randomly), so that the contributors would have notified of your request and possibly offer further contribution.
And for sure it whould have been better if you had specified which is the objective of the macro.

After having looked to some but not all of the messages in the original discussion I was not able to reverse engineer the code you published; so I am not able to modify it.
However, based on what I understood there, let me propose the following macro:
Code:
Sub GetSome()
Dim WArr, oArr(), I As Long, J As Long, K As Long, RR As Long
Dim LastC As Long, LastR As Long, rGap As Long, dLock As Long
Dim Picks As Long, ReTry As Boolean, rRND As Long
'
rGap = 10               '<<< How many rows between the main table and the results
'
Picks = Application.InputBox(prompt:="How many values to pick?", Title:="Tell me:", Type:=1)
If Picks = False Then Exit Sub
For I = 1 To Worksheets.Count
    If Left(Sheets(I).Name, 5) = "Code " Then
        With Sheets(I)
            LastC = .Range("A1").CurrentRegion.Columns.Count
            LastR = .Range("A1").CurrentRegion.Rows.Count
            WArr = .Range("A1").CurrentRegion.Value
            ReDim oArr(1 To Picks + 3, 1 To LastC)
            .Cells(LastR + rGap, "A").CurrentRegion.ClearContents
            For K = 1 To Picks + 1
                For J = 1 To LastC
                    dLock = 0
reRND:
                    DoEvents
                    rRND = Int((LastR - 1) * Rnd + 2)
                    If K = 1 Then rRND = 1
                    If WArr(rRND, J) <> "" Then
                        ccval = WArr(rRND, J)
                        oArr(K, J) = ccval
                        For RR = 2 To UBound(WArr)
                            If WArr(RR, J) = ccval Then
                                WArr(RR, J) = Empty
                            End If
                        Next RR
                        ReTry = False
                        dLock = 0
                    Else
                        dLock = dLock + 1
                        ReTry = True
                    End If
                    If ReTry And dLock < 5000 Then GoTo reRND
                Next J
            Next K
            .Cells(LastR + rGap, 1).Resize(UBound(oArr), UBound(oArr, 2)) = oArr
        End With
    End If
Next I
MsgBox ("Completed...")
End Sub
It scans the available worksheets; on those whose name starts with "Code " it read the area starting at A1 and ending at the first free column + the first free row; for each Column it fetches N values and copy thes N values X lines below the original tables.
N (the number of items to pick) is controlled by an Inputbox; X is "wired" into the code (see the instruction marked <<<); since the tables have different lenght, the starting row for the results changes on each sheet. If this is a problem then it is easy setting the same row on each of the sheets.

If in the column there are less than N unique elements then some of the cells will be left empty.
The macro clears the result area before extracting the results; since I use "CurrentRegion" to identify the area it is important that the column at the right of the main table is kept free.

Test it, while waiting for @Peter_SSs and @aRandomHelper possible contribution

Bye
 

Forum statistics

Threads
1,148,362
Messages
5,746,263
Members
424,001
Latest member
Sophiemakescakes

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top