vendredi 19 novembre 2021

Vba Code choose random number and copy to another rows

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.

  1. 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.

enter image description here

Image 2 is what we require the code run to choose 4 continuous numbers in any part of the columns.

enter image description here

  1. 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