Randomize cell arrangement in a given range

[|||||||E|||||||]

Hi All. Didn't find anything in the search results for this. Apologizes if it has surfaced before.

Building a quiz and need VBA code to randomly re-arrange cells within a given range. Answers to the quiz are one an "Answers" worksheet. Cells A8:O13 are linking to those answers.

Starting point:



VBA code should randomly re-arrange those cells, but maintain the links within those cells:

Random re-arrange:



Any help you can provide would be greatly appreciated. Thanks!

 

[Gerald Higgins]

Hi, welcome to the board.

I think if I were doing this, I would take a slightly different approach.
Moving the formulas around into random new locations can surely be done, but seems difficult to me.

Instead, why not use the OFFSET function, and randomise the column and row offset values within the OFFSET functions ?

You could do this by setting up a table containing all of your column and row values for your output range, then use the RAND() function to assign a rank to each of these values, and then perhaps use a combination of OFFSET and LARGE to select these column and row values in the sequence implied by the RAND() function.

 

[|||||||E|||||||]

I'm not familiar with the use of RAND, OFFSET, nor LARGE. Not sure how that could be implemented...

 

[Gerald Higgins]

OK I'll try and work up an example over the weekend.

 

[MickG]

Perhaps this example may give you what you want:-
https://app.box.com/s/gkyqwq191nzliyi8sbb6wvnf1vo0pgna

 

[|||||||E|||||||]

That's exactly what I need MickG! Unfortunately, I tried to implement the code into my worksheet and it didn't mesh well. I'm using module macros with buttons. That code is in the Sheet object, and I can't even see what code the buttons are triggering. It seems to be locked down.

Also, I'm not sure what the yellow and green ranges are doing on Sheet2.

Uploaded my current version to:

https://drop.me/BVzXdb

 

[MickG]

Your code seems to be working Ok without my code.
What do you want to add from my code, perhaps just the Randomizing ??

 

[|||||||E|||||||]

Correct. Everything is working, except the random rearrangement of the answers on the Quiz worksheet (which should pull from the Key worksheet).

The results of your example was perfect, but I couldn't recreate the code given our different approaches.

 

[MickG]

Try this , I put it in the "Next Country"(Random) code.

[COLOR="Navy"]Sub[/COLOR] Random()

Application.ScreenUpdating = False

Sheets("Key").Select

[COLOR="Navy"]Dim[/COLOR] RowNum [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
RowNum = Range("A" & Rows.Count).End(xlUp).Row

[COLOR="Navy"]Dim[/COLOR] RNG1 [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] RNG1 = Range("A2:A" & RowNum)

[COLOR="Navy"]Dim[/COLOR] randomCell1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
    randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1

[COLOR="Navy"]With[/COLOR] RNG1.Cells(randomCell1)
    .Select
    Selection.Copy
[COLOR="Navy"]End[/COLOR] With

Sheets("Quiz").Select
    Range("H3").Select
    Selection.PasteSpecial Paste:=xlPasteValues


'[COLOR="Green"][B]#############[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
c = 8
[COLOR="Navy"]With[/COLOR] Sheets("Key")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]With[/COLOR] Sheets("Quiz")
        Ac = Ac + 1
        .Cells(c, Ac) = Dn.Value
            [COLOR="Navy"]If[/COLOR] Ac = 15 [COLOR="Navy"]Then[/COLOR]
                c = c + 1: Ac = 0
            [COLOR="Navy"]End[/COLOR] If
     [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] fd [COLOR="Navy"]As[/COLOR] Boolean

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
       fd = False
       [COLOR="Navy"]Do[/COLOR] Until fd
        Col = Application.RandBetween(1, 15)
        Rw = Application.RandBetween(8, 11)
        [COLOR="Navy"]If[/COLOR] Not Cells(Rw, Col) = vbNullString [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not .exists(Cells(Rw, Col).Address) [COLOR="Navy"]Then[/COLOR]
                .Add (Cells(Rw, Col).Address), Nothing
                     Cells(Rw, Col) = Dn.Value
                    fd = True
            [COLOR="Navy"]End[/COLOR] If
         [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]Loop[/COLOR]
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With

'[COLOR="Green"][B]############[/B][/COLOR]

Application.ScreenUpdating = True

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[|||||||E|||||||]

Amazing Mick! That works perfect. Thank you so much for the help. Made a few minor changes and cleaned up, here is the final version:

https://drop.me/BVzXqP