Extracting number from a range

[Goalexcel]

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

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

Transfer - Dropbox

Dropbox is a free service that lets you bring your photos, docs, and videos anywhere and share them easily. Never email yourself a file again!

www.dropbox.com

 

[Anthony47]

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:

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