Randomly Select 4 Column Ranges and Copy and Paste to Another Worksheet

[coliervile]

Hello everyone,

I'm looking for a macro that will randomly select four columns ranges and copy to another worksheet. On Sheet2 I have a list data in D8:AA31 I would like a macro that will randomly select 4 columns and copy the range from row 8 to row AA31 then paste the first the first range in Sheet1 A1:25, then the second range in Sheet1 C1:C24, the third range in Sheet1 F1:F24, and then range four in Sheet1 H1:H24. Is there a macro out there that randomly select these ranges and then copy and paste?

[coliervile]

I thought I had my problem answered, but this coding is copying across the rows instead of down the column... what did I miss in the coding? I do have data from A1:A24 as well as A1:X24.

Public Sub RandCols(first As Long, last As Long, _
    colNo As Long)
    Dim i As Long, r As Long, temp As Long, k As Long
     
    ReDim iArr(first To last) As Long
    For i = first To last: iArr(i) = i: Next i
        For i = 1 To colNo
            r = Int(Rnd() * (last - first + 1 - (i - 1))) _
            + (first + (i - 1))
            temp = iArr(r): iArr(r) = iArr(first + i - 1): _
            iArr(first + i - 1) = temp
        Next i
        ReDim Preserve iArr(first To first + colNo - 1)
        For k = 1 To colNo
            Rows(iArr(k) & ":" & iArr(k)).Copy Destination:=Sheets("Sheet2").Range("A" & k)
        Next
    End Sub
     
     
    Sub getColumn()
        Dim firstColRow As Long, lastColRow As Long, noCOL As Long
        firstColRow = 1 ' start of data
        lastColRow = 24 'end of data
        noCOL = 4 'no of columns to select
        RandCols first:=firstColRow, last:=lastColRow, colNo:=noCOL
    End Sub

[Kenneth Hobs]

It would have been best to reply to your first post.

Can you post an example workbook?

You should check your code as it does not reflect the columns from Sheet2. You sent columns 1 to 24 to the Sub RandandCols where it should have been 4 to 27. I think you could send the 1 to 24 and then add 3 to the 4 random column numbers in the Rows line that needs changed anyway.

I will look at this later tonight to see if you have a solution. I think you are close. The rows line is all that needs a tweak I suspect.

[coliervile]

Thanks Mr. Hobs for looking at my question. This coding was placed in a text workbook instead of the actual one for testing purposes. The data is on Sheet1 and gets pasted on Sheet2. Here is the information on worksheet one... the columns are A to X.

18	23	4	20	21	6	14	11	16	18	9	22	19	17	13	2	7	1	10	8	24	5	15	3
3	6	11	3	4	13	21	18	23	1	16	5	2	24	20	9	14	8	17	15	7	12	22	10
14	2	7	23	24	9	17	14	19	21	12	1	22	20	16	5	10	4	13	11	3	8	18	6
10	14	19	11	12	21	5	2	7	9	24	13	10	8	4	17	22	16	1	23	15	20	6	18
3	24	5	21	22	7	15	12	17	19	10	23	20	18	14	3	8	2	11	9	1	6	16	4
1	5	10	2	3	12	20	17	22	24	15	4	1	23	19	8	13	7	16	14	6	11	21	9
4	11	16	8	9	18	2	23	4	6	21	10	7	5	1	14	19	13	22	20	12	17	3	15
12	3	8	24	1	10	18	15	20	22	13	2	23	21	17	6	11	5	14	12	4	9	19	7
17	8	13	5	6	15	23	20	1	3	18	7	4	2	22	11	16	10	19	17	9	14	24	12
8	19	24	16	17	2	10	7	12	14	5	18	15	13	9	22	3	21	6	4	20	1	11	23
5	10	15	7	8	17	1	22	3	5	20	9	6	4	24	13	18	12	21	19	11	16	2	14
20	7	12	4	5	14	22	19	24	2	17	6	3	1	21	10	15	9	18	16	8	13	23	11
19	18	23	15	16	1	9	6	11	13	4	17	14	12	8	21	2	20	5	3	19	24	10	22
7	12	17	9	10	19	3	24	5	7	22	11	8	6	2	15	20	14	23	21	13	18	4	16
2	4	9	1	2	11	19	16	21	23	14	3	24	22	18	7	12	6	15	13	5	10	20	8
10	16	21	13	14	23	7	4	9	11	2	15	12	10	6	19	24	18	3	1	17	22	8	20
8	22	3	19	20	5	13	10	15	17	8	21	18	16	12	1	6	24	9	7	23	4	14	2
3	13	18	10	11	20	4	1	6	8	23	12	9	7	3	16	21	15	24	22	14	19	5	17
2	21	2	18	19	4	12	9	14	16	7	20	17	15	11	24	5	23	8	6	22	3	13	1
1	1	6	22	23	8	16	13	18	20	11	24	21	19	15	4	9	3	12	10	2	7	17	5
6	17	22	14	15	24	8	5	10	12	3	16	13	11	7	20	1	19	4	2	18	23	9	21
8	20	1	17	18	3	11	8	13	15	6	19	16	14	10	23	4	22	7	5	21	2	12	24
17	15	20	12	13	22	6	3	8	10	1	14	11	9	5	18	23	17	2	24	16	21	7	19
11	9	14	6	7	16	24	21	2	4	19	8	5	3	23	12	17	11	20	18	10	15	1	13

[coliervile]

The data on Sheet2 come out as below....columns A to X but rows 1 to 4. My code is copying 4 random rows istead of columns.

6	17	22	14	15	24	8	5	10	12	3	16	13	11	7	20	1	19	4	2	18	23	9	21
1	1	6	22	23	8	16	13	18	20	11	24	21	19	15	4	9	3	12	10	2	7	17	5
5	10	15	7	8	17	1	22	3	5	20	9	6	4	24	13	18	12	21	19	11	16	2	14
11	9	14	6	7	16	24	21	2	4	19	8	5	3	23	12	17	11	20	18	10	15	1	13

[Kenneth Hobs]

Right, but if you attach a workbook, it just helps us help you more easily.

You posted the reverse of what you said in your first post. You are now pasting from sheet1 to sheet2. This is the usual need though your first post said from sheet2 to sheet 1. This is why posting a mocked up simple workbook helps us help you more easily and accurately.

Always, make a backup of your file to test code.

[coliervile]

I don't see anything that enables me to attach a file, any ideas?

[Kenneth Hobs]

Click the Go Advanced button in a reply and select the paperclip icon. From there, you can browse and select your file or use drag and drop if you have that option set in your Settings.

[Kenneth Hobs]

I modified your random sub to make it into a function since this sort of thing is often needed. One might want to add an option to sort ascending, descending, or no sorting in the function.

Using your data, some column data is missing based on your first post of data from column A to AA. I made two Sub options as I did not fully understand what you wanted. I cleared sheet2 in the subs so that you can run several tests to see how each sub works. When you notice seemingly blank column data, that is because your data has missing column data for the random column number found in the function. You can uncommment some parts to see how some parts are working if needed. Or, just delete the commented lines.

Option Explicit
Option Base 1


Sub opt1()
  Dim a() As Variant, b() As Variant, i As Long
  a() = RndIntPick(4, 27, 4)
  'Debug.Print Join(a(), vbLf), vbLf
  b() = Array("A8", "C8", "F8", "H8")
  
  Worksheets("Sheet2").UsedRange.Clear
  
  With Worksheets("Sheet1")
    For i = 1 To 4
    'Debug.Print .Range(.Cells(1, a(i)), .Cells(24, a(i))).Address
    .Range(.Cells(1, a(i)), .Cells(24, a(i))).Copy Worksheets("Sheet2").Range(b(i))
    Next i
  End With
End Sub


Sub opt2()
  Dim a() As Variant, b() As Variant, i As Long
  a() = RndIntPick(4, 27, 4)
  b() = Array("A8", "C8", "F8", "H8")
  
  Worksheets("Sheet2").UsedRange.Clear
  
  With Worksheets("Sheet1")
    For i = 1 To 4
    .Range(.Cells(1, a(i)), .Cells(24, a(i))).Copy Worksheets("Sheet2").Cells(1, i)
    Next i
  End With
End Sub


Function RndIntPick(first As Long, last As Long, _
  noPick As Long) As Variant
  Dim i As Long, r As Long, temp As Long, k As Long
  ReDim iArr(first To last) As Variant
  Dim a() As Variant
  
  For i = first To last
    iArr(i) = i
  Next i
  
  Randomize
  For i = 1 To noPick
      r = Int(Rnd() * (last - first + 1 - (i - 1))) + (first + (i - 1))
      temp = iArr(r)
      iArr(r) = iArr(first + i - 1)
      iArr(first + i - 1) = temp
  Next i
  
  ReDim Preserve iArr(first To first + noPick - 1)
  ReDim a(1 To noPick)
  For r = 1 To noPick
    a(r) = iArr(LBound(iArr) + r - 1)
  Next r
  RndIntPick = a()
End Function


Sub test_RndIntPick()
  Debug.Print Join(RndIntPick(5, 10, 5), vbLf), vbLf
End Sub

[coliervile]

Thank you so very much Kenneth for the information. I'll have to send it tomorrow since I'm off of work and its a work file.

[Kenneth Hobs]

This is mostly the same but I added a sort option. I typically need that option myself.

You can uncomment the line that calls RndIntPick() and comment out the line below it in the opt subs if you want to test the sort option. Uncomment the last debug line to see which addresses in the Immediate window for the ranges are copied.

You can quickly test the RndInPick() routine in the Test sub.

Option Explicit
Option Base 1

' http://www.vbaexpress.com/forum/showthread.php?48491-Randomly-Select-4-Column-Ranges-and-Copy-and-Paste-to-Another-Worksheet&p=302051

Sub opt1()
  Dim a() As Variant, b() As Variant, i As Long
  'a() = RndIntPick(4, 27, 4, True)  'True=Sort a()
  a() = RndIntPick(4, 27, 4)
  'Debug.Print Join(a(), vbLf), vbLf
  b() = Array("A8", "C8", "F8", "H8")
  
  Worksheets("Sheet2").UsedRange.Clear
  
  With Worksheets("Sheet1")
    For i = 1 To 4
    'Debug.Print .Range(.Cells(1, a(i)), .Cells(24, a(i))).Address
    .Range(.Cells(1, a(i)), .Cells(24, a(i))).Copy Worksheets("Sheet2").Range(b(i))
    Next i
  End With
End Sub


Sub opt2()
  Dim a() As Variant, i As Long
  'a() = RndIntPick(4, 27, 4, true)  'True=Sort a()
  a() = RndIntPick(4, 27, 4)
  
  Worksheets("Sheet2").UsedRange.Clear
  
  With Worksheets("Sheet1")
    For i = 1 To 4
    .Range(.Cells(1, a(i)), .Cells(24, a(i))).Copy Worksheets("Sheet2").Cells(8, i)
    Next i
  End With
End Sub


Function RndIntPick(first As Long, last As Long, _
  noPick As Long, Optional bSort As Boolean = False) As Variant
  Dim i As Long, r As Long, temp As Long, k As Long
  ReDim iArr(first To last) As Variant
  Dim a() As Variant
  
  For i = first To last
    iArr(i) = i
  Next i
  
  Randomize
  For i = 1 To noPick
      r = Int(Rnd() * (last - first + 1 - (i - 1))) + (first + (i - 1))
      temp = iArr(r)
      iArr(r) = iArr(first + i - 1)
      iArr(first + i - 1) = temp
  Next i
  
  ReDim Preserve iArr(first To first + noPick - 1)
  ReDim a(1 To noPick)
  For r = 1 To noPick
    a(r) = iArr(LBound(iArr) + r - 1)
  Next r
  
  If bSort = True Then
    RndIntPick = InsertSort(a())
    Else
    RndIntPick = a()
  End If
End Function


Sub test_RndIntPick()
  Dim a() As Variant
  
  a() = RndIntPick(5, 10, 5)
  Debug.Print Join(a(), vbLf), vbLf
  
  a() = InsertSort(a())
  Debug.Print Join(a(), vbLf), vbLf
End Sub

'http://vbadeveloper.net/sortingvbabubbleinsertionquick.pdf
' Changed array to variant by Kenneth Hobson, 12/19/13.
Function InsertSort(Array_Values) As Variant 'Sorts ascending
 Dim nums() As Double
 Dim limit As Long
 Dim i As Long, j As Long
 Dim num_greater
 Dim new_array() As Variant
 Dim base_variable As Double
 Dim Rank As Long
 
 limit = UBound(Array_Values)
 
 ReDim Preserve nums(1 To limit)
 ReDim Preserve new_array(1 To limit)
 
 For i = 1 To limit
  nums(i) = Array_Values(i)
 Next i
 
 For i = 1 To limit
  num_greater = 0
  base_variable = nums(i)
  For j = 1 To limit
    If base_variable < nums(j) Then
      num_greater = num_greater + 1
    End If
  Next j
    
  Rank = limit - num_greater
  new_array(Rank) = nums(i)
 Next i
 
 'InsertSort = WorksheetFunction.Transpose(new_array)
 InsertSort = new_array
End Function

[snb]

Sort an array:

Function sorted_array(sn)
    With CreateObject("System.Collections.ArrayList")
       For Each cl In sn
         .Add cl
       Next
       
       .Sort
       sorted_array = .toarray()
    End With
End Function

Sub M_snb()
    MsgBox Join(sorted_array(Array(12, 573, 2, 86)), vbLf)
End Sub

[Kenneth Hobs]

I had looked at that sort method some years back snb. I do like it for my own use. It does depend on the user having that object but most computers these days have it installed by default from the vb.net framework files. One thing I like about it is option to sort in reverse order as well. Since I do that "sort" of thing every so often, I added that option. In speed tests for a 10,000 element integer array, InsertSort took 2.85 seconds on the average and ArrayListSort() took 0.10 seconds as you can see in my ken() sub. There are several VBA sort methods out there though vb.net's arraylist method is certainly at or near the top in my book.

Option Explicit
Option Base 1

Sub opt1()
  Dim a() As Variant, b() As Variant, i As Long
  'a() = RndIntPick(4, 27, 4, True)  'True=Sort a()
  a() = RndIntPick(4, 27, 4)
  'Debug.Print Join(a(), vbLf), vbLf
  b() = Array("A8", "C8", "F8", "H8")
  
  Worksheets("Sheet2").UsedRange.Clear
  
  With Worksheets("Sheet1")
    For i = 1 To 4
    'Debug.Print .Range(.Cells(1, a(i)), .Cells(24, a(i))).Address
    .Range(.Cells(1, a(i)), .Cells(24, a(i))).Copy Worksheets("Sheet2").Range(b(i))
    Next i
  End With
End Sub


Sub opt2()
  Dim a() As Variant, i As Long
  'a() = RndIntPick(4, 27, 4, true)  'True=Sort a()
  a() = RndIntPick(4, 27, 4)
  
  Worksheets("Sheet2").UsedRange.Clear
  
  With Worksheets("Sheet1")
    For i = 1 To 4
    .Range(.Cells(1, a(i)), .Cells(24, a(i))).Copy Worksheets("Sheet2").Cells(8, i)
    Next i
  End With
End Sub


Function RndIntPick(first As Long, last As Long, _
  noPick As Long, Optional bSort As Boolean = False) As Variant
  Dim i As Long, r As Long, temp As Long, k As Long
  ReDim iArr(first To last) As Variant
  Dim a() As Variant
  
  For i = first To last
    iArr(i) = i
  Next i
  
  Randomize
  For i = 1 To noPick
      r = Int(Rnd() * (last - first + 1 - (i - 1))) + (first + (i - 1))
      temp = iArr(r)
      iArr(r) = iArr(first + i - 1)
      iArr(first + i - 1) = temp
  Next i
  
  ReDim Preserve iArr(first To first + noPick - 1)
  ReDim a(1 To noPick)
  For r = 1 To noPick
    a(r) = iArr(LBound(iArr) + r - 1)
  Next r
  
  If bSort = True Then
    RndIntPick = ArrayListSort(a())
    Else
    RndIntPick = a()
  End If
End Function

Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True)
  With CreateObject("System.Collections.ArrayList")
    Dim cl As Variant
    For Each cl In sn
        .Add cl
    Next
     
    .Sort 'Sort ascendending
    If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
    ArrayListSort = .toarray()
  End With
End Function

Sub ken()
  Dim t1 As Double, i As Integer, a(1 To 10000) As Variant
  For i = 1 To 10000
    a(i) = i
  Next i
  
  t1 = Timer  '2.85 s
  MsgBox Join(InsertSort(a()), vbLf), vbInformation, CStr(Timer - t1) & " seconds for InsertSort."
  
  t1 = Timer  '0.10 s
  MsgBox Join(ArrayListSort(a()), vbLf), vbInformation, CStr(Timer - t1) & " seconds for ArrayList sort."
End Sub

[snb]

@KH

You appeased my 'worries'.
Of course it would be daft to think you were not familiar with it.
To add to the other advantages I find it more 'readable' (adddin,sorting,writin) than other methods I consider to be second best options to a lacking facility in VBA.

[snb]

If you need 4 columns containing 24 random unique numbers you can use:

Sub M_snb()
[sheet2!B1:E24] = "=rand()"
For j = 0 To 3
[sheet2!B1:B24].Offset(, j) = Evaluate("index(rank(Sheet2!" & [B1:B24].Offset(, j).Address(0, 0) & ",Sheet2!" & [B1:B24].Offset(, j).Address(0, 0) & "),)")
Next
End Sub

[coliervile]

snb thanks for your ideas. Unfortunately my work day was to get around and try it. I wi look at it over the weekend and get back to you.

thank you...

[coliervile]

Kenneth thanks for your ideas. I had just enough time to try out opt1 and opt2 and both work well. One question I have is that when I run both opt1 and opt2, they are run separately, I will on occasion he an empty column of data. Is there a particular reason why that would happen since I have the data on the other sheet?

Thank you...

[Kenneth Hobs]

From post 9:

Using your data, some column data is missing based on your first post of data from column A to AA.

Obviously, column AA is the 27th column. If your data does not go from column 1 to 27, then make it dynamic or hard code the actual last column number.