I have a VBA codes that help me with repetitive task, but now there are new data and changes. I was searching a lot to try to change the macro, I would like to ask for your help and thank you in advance.
- Code is helping to pick up random number in non-continuous rows, code need to change to choose 4 continuous numbers.
Image 1 is how the code run, choosing random numbers non continuous rows, copy those random number in A20 and highlight with colors.
Image 2 is what we require the code run to choose 4 continuous numbers in any part of the columns.
- The data has relative sheet from 1 until sheet 8, not absolute number, also the range start row A1 until column T always change, column and rows require code with relative function count end.
Here is the code:
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 8 'Numbers of sheet
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
Aucun commentaire:
Enregistrer un commentaire