Extracting number from a range randomly

[Goalexcel]

Hello Expert, please kindly advise what is the best method to extract numbers from a range randomly
I have a series of numbers in the range of A1 to T16. I would like to extract 3 differents numbers from each columns, and place them in column A21, B21so on. I wonder. if there is a way to do that easily.

 

[Goalexcel]

I am not really convinced but given my question and your answer, try this. At the moment it only works on the active sheet and column A. If it is what you actually want then it can be extended to other columns and sheets if required.

Sub List4()
  Dim PrevRuns As Long, fr As Long
  Dim Clrs As Variant, FirstRows As Variant
 
  Clrs = Array(vbYellow, vbBlue, vbGreen, vbCyan)
  FirstRows = Array(2, 14, 6, 10)
  PrevRuns = (Range("A" & Rows.Count).End(xlUp).CurrentRegion.Columns(1).SpecialCells(xlConstants).Count - 1) / 4
  If PrevRuns < 4 Then
    With Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4)
      .Value = Range("A" & FirstRows(LBound(FirstRows) + PrevRuns)).Resize(4).Value
      .Interior.Color = Clrs(LBound(Clrs) + PrevRuns)
    End With
    Range("A" & FirstRows(LBound(FirstRows) + PrevRuns)).Resize(4).Interior.Color = Clrs(LBound(Clrs) + PrevRuns)
  End If
End Sub

Thank you for your replay. I run code but not show nothing.

 

[Peter_SSs]

Thank you for your replay. I run code but not show nothing.

This is what it did for me

Goalexcel TestPicknumbers.xlsm
	A
1	Sect 1
2	1101
3	1102
4	1103
5	1104
6	1105
7	1106
8	1107
9	1108
10	1109
11	1110
12	1111
13	1112
14	1113
15	1114
16	1115
17	1116
18
19
20	Sect 1
21	1101
22	1102
23	1103
24	1104
25	1113
26	1114
27	1115
28	1116
29	1105
30	1106
31	1107
32	1108
33	1109
34	1110
35	1111
36	1112
37
Group 1

 

[Goalexcel]

This is what it did for me

Goalexcel TestPicknumbers.xlsm
	A
1	Sect 1
2	1101
3	1102
4	1103
5	1104
6	1105
7	1106
8	1107
9	1108
10	1109
11	1110
12	1111
13	1112
14	1113
15	1114
16	1115
17	1116
18
19
20	Sect 1
21	1101
22	1102
23	1103
24	1104
25	1113
26	1114
27	1115
28	1116
29	1105
30	1106
31	1107
32	1108
33	1109
34	1110
35	1111
36	1112
37
Group 1

Mr. @Peter_SSs , Please kindly take a look of my 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

 

[Peter_SSs]

OK, try this instead

Sub List4_v2()
  Dim PrevRuns As Long, fr As Long
  Dim Clrs As Variant, FirstRows As Variant
  
  Clrs = Array(vbYellow, vbBlue, vbGreen, vbCyan)
  FirstRows = Array(2, 14, 6, 10)
  With Range("A" & Rows.Count).End(xlUp)
    If IsNumeric(.Value) Then
      PrevRuns = (.CurrentRegion.Columns(1).SpecialCells(xlConstants).Count - 1) / 4
    Else
      PrevRuns = 0
    End If
  End With
  If PrevRuns < 4 Then
    With Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4)
      .Value = Range("A" & FirstRows(LBound(FirstRows) + PrevRuns)).Resize(4).Value
      .Interior.Color = Clrs(LBound(Clrs) + PrevRuns)
    End With
    Range("A" & FirstRows(LBound(FirstRows) + PrevRuns)).Resize(4).Interior.Color = Clrs(LBound(Clrs) + PrevRuns)
  End If
End Sub

 

[Goalexcel]

OK, try this instead

Sub List4_v2()
  Dim PrevRuns As Long, fr As Long
  Dim Clrs As Variant, FirstRows As Variant
 
  Clrs = Array(vbYellow, vbBlue, vbGreen, vbCyan)
  FirstRows = Array(2, 14, 6, 10)
  With Range("A" & Rows.Count).End(xlUp)
    If IsNumeric(.Value) Then
      PrevRuns = (.CurrentRegion.Columns(1).SpecialCells(xlConstants).Count - 1) / 4
    Else
      PrevRuns = 0
    End If
  End With
  If PrevRuns < 4 Then
    With Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4)
      .Value = Range("A" & FirstRows(LBound(FirstRows) + PrevRuns)).Resize(4).Value
      .Interior.Color = Clrs(LBound(Clrs) + PrevRuns)
    End With
    Range("A" & FirstRows(LBound(FirstRows) + PrevRuns)).Resize(4).Interior.Color = Clrs(LBound(Clrs) + PrevRuns)
  End If
End Sub

Thank you @Peter_SSs it's work in column A.

 

[Peter_SSs]

Thank you @Peter_SSs it's work in column A.

So do you want that same thing in all columns and all worksheets?

 

[Goalexcel]

So do you want that same thing in all columns and all worksheets?

@Peter_SSs , yes the code need to run in active worksheet, active sheet (sheet1 until the end) from rows A1 count until the end.

 

[Peter_SSs]

Sub List4_v3()
  Dim PrevRuns As Long, fr As Long, ShNum As Long, ResultsHeaderRow As Long, LBC As Long, LBF As Long, c As Long
  Dim Clrs As Variant, FirstRows As Variant
  
  Clrs = Array(vbYellow, vbBlue, vbGreen, vbCyan)
  LBC = LBound(Clrs)
  FirstRows = Array(2, 14, 6, 10)
  LBF = LBound(FirstRows)
  For ShNum = 1 To Sheets.Count
    With Sheets(ShNum)
      ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
      PrevRuns = (.Range("A" & Rows.Count).End(xlUp).Row - ResultsHeaderRow) / 4
      If PrevRuns < 4 Then
        For c = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
          With .Cells(Rows.Count, c).End(xlUp).Offset(1).Resize(4)
            .Value = .Parent.Cells(FirstRows(LBF + PrevRuns), c).Resize(4).Value
            .Interior.Color = Clrs(LBC + PrevRuns)
          End With
          .Cells(FirstRows(LBF + PrevRuns), c).Resize(4).Interior.Color = Clrs(LBC + PrevRuns)
        Next c
      End If
    End With
  Next ShNum
End Sub

 

[Goalexcel]

Sub List4_v3()
  Dim PrevRuns As Long, fr As Long, ShNum As Long, ResultsHeaderRow As Long, LBC As Long, LBF As Long, c As Long
  Dim Clrs As Variant, FirstRows As Variant
 
  Clrs = Array(vbYellow, vbBlue, vbGreen, vbCyan)
  LBC = LBound(Clrs)
  FirstRows = Array(2, 14, 6, 10)
  LBF = LBound(FirstRows)
  For ShNum = 1 To Sheets.Count
    With Sheets(ShNum)
      ResultsHeaderRow = .Range("A1").End(xlDown).End(xlDown).Row
      PrevRuns = (.Range("A" & Rows.Count).End(xlUp).Row - ResultsHeaderRow) / 4
      If PrevRuns < 4 Then
        For c = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
          With .Cells(Rows.Count, c).End(xlUp).Offset(1).Resize(4)
            .Value = .Parent.Cells(FirstRows(LBF + PrevRuns), c).Resize(4).Value
            .Interior.Color = Clrs(LBC + PrevRuns)
          End With
          .Cells(FirstRows(LBF + PrevRuns), c).Resize(4).Interior.Color = Clrs(LBC + PrevRuns)
        Next c
      End If
    End With
  Next ShNum
End Sub

Thank you so much @Peter_SSs for your time, working on it.

 

[Goalexcel]

@Peter_SSs , can kindly ask you for help to make work with macro attached excel file

Laur Brown sent you 1 item

Tracking number2.xlsx

www.dropbox.com