Using Excel 2010
Hello,
I need VBA to Random shuffle only 3 columns for example column D, column E, Column F as long as data find in the columns…in this example length of each column is the same but can be the different.
I have attached workbook with few rows example, but in real max rows can be 65000
Please help.
Regards,
Moti
May I ask:
- These columns are independent of each other, so when shuffling, it only shuffles within that column, right?
- After shuffling, the content of the items remains unchanged, only the positions within the column are altered, correct?
It would be best if you could provide an example for one column, with 2 pieces of data: before and after the code runs.
Quang PT
Hello bebo021999, thank you for asking a question here is my answer. Yes It is correct.Originally Posted by bebo021999
This question gives me another idea instead of shuffling in the same columns can it be shuffled in the next Column I, J, K, L (original remain original) as per example sheet attached.
Example sheet attached.
Regards,
Moti
Ok I think it will be good shuffle in the same columns. (column D, column E, Column F).
Option Explicit Sub shuffle() Dim a, b, c Dim i As Long, j As Long, k As Long, lr As Long Cells(10, 6).Resize(10000, 4).ClearContents For i = 4 To 6 lr = Cells(Rows.Count, i).End(xlUp).Row a = Cells(6, i).Resize(lr - 5, 1) ReDim b(1 To lr - 5): ReDim c(1 To lr - 5) For j = 1 To lr - 5 b(j) = Rnd() Next j For j = 1 To lr - 5 k = Application.Match(Application.Small(b, j), b, 0) c(j) = a(k, 1) Next j Cells(6, i + 7).Resize(UBound(c, 1), 1) = Application.Transpose(c) Next i Cells(6, 3).Resize(10000, 1).Copy Cells(6, 10) End Sub
If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.
Run this in your first file
Sub jec() Dim sq, sp Dim j As Long, jj As Long, x As Long Range("D6", Range("F" & Rows.Count).End(xlUp)).Name = "ar" sq = [ar] [ar].Offset(, 4) = "=rand()" sp = [index((rank(offset(ar,,4),offset(ar,,4)))-1,)] [ar].Offset(, 4).ClearContents ReDim ary(UBound(sq) * UBound(sq, 2), 0) For j = 1 To UBound(sq) For jj = 1 To UBound(sq, 2) ary(x, 0) = sq(j, jj) x = x + 1 Next Next For j = 1 To UBound(sp) For jj = 1 To UBound(sp, 2) sq(j, jj) = ary(sp(j, jj), 0) Next Next Range("D6").Resize(j - 1, jj - 1) = sq End Sub
JEC, thank you, Ok it is good shuffling in the same columns. (Column D, column E, Column F) no problem but there is one issue need 3 columns H, I, j empty and I got data in it.
Regards,
Moti
You could change that offset(,4) to offset(,99) everywhere
Are you still using Excel 2010? If you have upgraded to 365, it would be very easy to shuffle into new columns.
Trevor Shuttleworth - Retired Excel/VBA Consultant
I dream of a better world where chickens can cross the road without having their motives questioned
'Being unapologetic means never having to say you're sorry' John Cooper Clarke
Hello TMS, yes using excel 2010, I need a VBA that shuffle in the same columns or in others but without the helper columns.
Regards,
Moti
Says 2010 at the very top of post #1.
Ali
Enthusiastic self-taught user of MS Excel who's always learning!
Don't forget to say "thank you" in your thread to anyone who has offered you help. It's a universal courtesy.
You can reward them by clicking on * Add Reputation below their user name on the left, if you wish.
NB: as a Moderator, I never accept friendship requests.
Forum Rules (updated August 2023): please read them here.
Missed that ... shoulda gone to SpecSaversSays 2010 at the very top of post #1.
OK, try below code:
PHP Code:Option Explicit
Sub shuffle()
Dim lr&, i&, j&, r&, rng, res(), tmp
lr = Cells(Rows.Count, "C").End(xlUp).Row
rng = Range("C6:F" & lr).Value
For j = 2 To 4
For i = 1 To UBound(rng) - 1
r = WorksheetFunction.RandBetween(i + 1, UBound(rng))
tmp = rng(i, j): rng(i, j) = rng(r, j): rng(r, j) = tmp
Next
Next
Range("I6:L" & lr).Value = rng
End Sub
bebo021999, thank you, yes this worked perfect. Happy weekend.
Regards,
Moti
Hello JohnTopley, Thank you, yes it seems to work fine without the helper columns. When I run the code it is erasing the original data in column F10 to down. Please can you check it?
Regards,
Moti
Typo!Option Explicit Sub shuffle() Dim a, b, c Dim i As Long, j As Long, k As Long, lr As Long Cells(6, 10).Resize(10000, 4).ClearContents For i = 4 To 6 lr = Cells(Rows.Count, i).End(xlUp).Row a = Cells(6, i).Resize(lr - 5, 1) ReDim b(1 To lr - 5): ReDim c(1 To lr - 5) For j = 1 To lr - 5 b(j) = Rnd() Next j For j = 1 To lr - 5 k = Application.Match(Application.Small(b, j), b, 0) c(j) = a(k, 1) Next j Cells(6, i + 7).Resize(UBound(c, 1), 1) = Application.Transpose(c) Next i Cells(6, 3).Resize(10000, 1).Copy Cells(6, 10) End Sub
JohnTopley, thank you, yes this worked spot on.
Have a cheerful weekend.
Regards,
Moti
Glad you have a solution.
If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.
Also, you may not be aware that you can thank those who have helped you by clicking the small star icon (Next to Add Reputation) located in the lower left corner of the post in which the help was given. By doing so you can add to the reputation(s) of those who helped.
@Motilulla: Thanks for the rep, although the other guys did all the heavy lifting
Glad you have a solution
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks