Announcement

Collapse
No announcement yet.

Random Draw

Collapse
This topic is closed.
X
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Random Draw

    What I am doing is a spreadsheet for the sport of Team Roping, where you have a header and a heeler. People come and enter and then randomly draw their partners. But sometimes one person will enter Heading and Heeling. For example George entered heading and heeling.

    I have put a title on each column in Row 1.
    Column A has all of the Headers names in it,
    Column B has the following formula to randomly draw a Heeler, =INDEX($C$2:$C$14,RANK(D2,$D$2:$D$14))
    Column C has the Heelers names in it
    Column D has the following formula in it, =RAND()

    I need to know if there is a way that I can put in the formula, so the same name does not appear in Column A row 2 Column B row 2, for example George cannot be drawn with George?

    And how do I copy and paste just the values, after I have done the random draw in Column B, not the formula? I have tried the copy-paste special-values, but when I do that it randomly sorts them again, before it pastes.

    If anyone has any suggestions on how to change the spreadsheet to achieve this please let me know.

    Thanks.

  • #2
    Re: Random Draw

    Welcome to the OzGrid Forum!

    The following macro should do the job. It assumes that Row 1 has headings with the Headers names listed in column A starting in A2. The list of Heelers should be in column B (not C) starting in B2. The macro randomly shuffles the Heelers names in place until no one is paired against himself.
    Code:
    Sub ShuffleB()
        Dim i As Long, k As Long, n As Long, s As String, OK As Boolean
        n = Cells(65536, 1).End(xlUp).Row 'get number of headers
        If Cells(65536, 2).End(xlUp).Row <> n Then
            MsgBox "The number of Headers is not the same as the number of Heelers"
            Exit Sub
        End If
        Application.ScreenUpdating = False
        Randomize 'reset the seed
        Do
            'shuffle B
            For i = 2 To n
                k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                s = Cells(k, 2).Value
                Cells(k, 2).Value = Cells(i, 2).Value
                Cells(i, 2).Value = s
            Next i
            OK = True
            For i = 2 To n
                If Cells(i, 1).Value = Cells(i, 2).Value Then 'need to do it again
                    OK = False
                    Exit For
                End If
            Next i
        Loop Until OK
        Application.ScreenUpdating = True
    End Sub
    Last edited by PCI; September 17th, 2010, 14:23. Reason: Code tags changed from Vba to Code
    Please do not U2U (private message) me directly for questions that should be posted to the forum; any such U2Us will be ignored.

    Comment


    • #3
      Random Draw

      Thank you for the welcome and help Derk. Unfortunetly, I have never used macro's before. Can you please give me step by step instructions on how I would create and use this macro. Also do I need to put it in a certain cell? The spreadsheet I am using has 13 rows of names, although it may go up to 200.

      Again, thank you for all of your help.
      Last edited by hopeless; February 2nd, 2007, 03:02.

      Comment


      • #4
        Re: Random Draw

        To use the macro requires that you first open the VBA editor (VBE), then paste in the code, then run the code. Here are the details.
        1) Open the VBE by holding down the Alt key and pushing the F11 function key. This will open up a new window that may look a bit strange to you. On the menu bar, find the Insert menu and use it to insert a module.
        2) Copy the code and paste it into the new module window that opened (it should be the big window on the top right, with the cursor already in it).
        3) Close the VBE using the File menu and return to Excel.
        4) Once your names are set in coluimns A and B, you can run the macro by holding down the Alt key and pushing the F8 function key. In the dialog that pops up, select the name ShuffleB and push the Run button. That should do it. The macro will figure out how many names there are as long as there are no blanks within the lists and no entries below the lists in columns A or B.

        That should get you started.
        Please do not U2U (private message) me directly for questions that should be posted to the forum; any such U2Us will be ignored.

        Comment


        • #5
          Re: Random Draw

          Thank you, that worked great.

          Will this macro ensure that the same name is never in the same row. For example if I have George in Column A row 12, George can not be in Column B row 12.

          I would also like to shuffle Column A, so that they can be split up if one person enters numerous times. Can you please tell me what macro I would use for that.

          Your help is greatly appreciated.
          Last edited by hopeless; February 2nd, 2007, 04:56. Reason: question

          Comment


          • #6
            Re: Random Draw

            The macro now ensures that the same name cannot be paired with itself., so George cannot be in A12 and B12 after the macro is run. There is one caveat: If it isn't possible for an arrangement to be made (for example all of the names on both lists are George) then the macro will run forever trying to make the impossible arrangement.

            This macro should replace the earlier one. It adds a shuffle for column A.
            Code:
            Sub ShuffleB()
                Dim i As Long, k As Long, n As Long, s As String, OK As Boolean
                n = Cells(65536, 1).End(xlUp).Row 'get number of headers
                If Cells(65536, 2).End(xlUp).Row <> n Then
                    MsgBox "The number of Headers is not the same as the number of Heelers"
                    Exit Sub
                End If
                Application.ScreenUpdating = False
                Randomize 'reset the seed
                'Shuffle A once
                For i = 2 To n
                    k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                    s = Cells(k, 1).Value
                    Cells(k, 1).Value = Cells(i, 1).Value
                    Cells(i, 1).Value = s
                Next i
                Do
                     'shuffle B
                    For i = 2 To n
                        k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                        s = Cells(k, 2).Value
                        Cells(k, 2).Value = Cells(i, 2).Value
                        Cells(i, 2).Value = s
                    Next i
                    OK = True
                    For i = 2 To n
                        If Cells(i, 1).Value = Cells(i, 2).Value Then 'need to do it again
                            OK = False
                            Exit For
                        End If
                    Next i
                Loop Until OK
                Application.ScreenUpdating = True
            End Sub
            Last edited by ByTheCringe2; February 2nd, 2007, 07:14.
            Please do not U2U (private message) me directly for questions that should be posted to the forum; any such U2Us will be ignored.

            Comment


            • #7
              Re: Random Draw

              Oh shoot, one thing I forgot is to put the number beside each team.

              If I manually put in numbers in Column A and put the Headers in Column B and Heelers in Column C. Would the macro still work if I changed all of the Column A's to B's and all of the Column B's to C's.

              Sorry, I thought I had all of my basis covered.
              Last edited by hopeless; February 2nd, 2007, 08:50. Reason: question

              Comment


              • #8
                Re: Random Draw

                Derk, can you please help with this, I tried changing the A's to B's and B's to C's and it did not work. What would the new macro be?

                Thanks again.

                Comment


                • #9
                  Re: Random Draw

                  Try this version
                  Code:
                  Sub Shuffle() 'columns B and C
                      Dim i As Long, k As Long, n As Long, s As String, OK As Boolean
                      n = Cells(65536, 2).End(xlUp).Row 'get number of headers
                      If Cells(65536, 3).End(xlUp).Row <> n Then
                          MsgBox "The number of Headers is not the same as the number of Heelers"
                          Exit Sub
                      End If
                      Application.ScreenUpdating = False
                      Randomize 'reset the seed
                       'Shuffle B once
                      For i = 2 To n
                          k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                          s = Cells(k, 2).Value
                          Cells(k, 2).Value = Cells(i, 2).Value
                          Cells(i, 2).Value = s
                      Next i
                      Do
                           'shuffle C
                          For i = 2 To n
                              k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                              s = Cells(k, 3).Value
                              Cells(k, 3).Value = Cells(i, 3).Value
                              Cells(i, 3).Value = s
                          Next i
                          OK = True
                          For i = 2 To n
                              If Cells(i, 2).Value = Cells(i, 3).Value Then 'need to do it again
                                  OK = False
                                  Exit For
                              End If
                          Next i
                      Loop Until OK
                      Application.ScreenUpdating = True
                  End Sub
                  Last edited by PCI; September 17th, 2010, 14:22. Reason: Code tag changed from Vba to Code
                  Please do not U2U (private message) me directly for questions that should be posted to the forum; any such U2Us will be ignored.

                  Comment


                  • #10
                    Re: Random Draw

                    Used this spreadsheet and it worked great. Thank you so much for your help.

                    I was wondering if it would be possible to put in the macro, so that the same name in Column would be a few spaces apart.

                    For example, if I have a header (Column B) named Mike and he entered a couple of times. If the shuffle puts his name in row 2, it can not be in row 3 or 4.

                    If it is possible I would need this to happen in Column B and C.

                    Comment


                    • #11
                      Re: Random Draw

                      Here it is. If there are a lot of duplicate names it may run for a long time. I also put in a check to give up if after 20,000 shuffles a solution hasn't been found.
                      Sub Shuffle() 'columns B and C
                      Dim i As Long, k As Long, n As Long, s As String, OK As Boolean, iShuf As Long
                      Const maxShuf As Long = 20000 'max times to try to meet conditions
                      n = Cells(65536, 2).End(xlUp).Row 'get number of headers
                      If Cells(65536, 3).End(xlUp).Row <> n Then
                      MsgBox "The number of Headers is not the same as the number of Heelers"
                      Exit Sub
                      End If
                      Application.ScreenUpdating = False
                      Randomize 'reset the seed
                      'Shuffle B as needed
                      iShuf = 0
                      Do
                      For i = 2 To n
                      k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                      s = Cells(k, 2).Value
                      Cells(k, 2).Value = Cells(i, 2).Value
                      Cells(i, 2).Value = s
                      Next i
                      OK = True
                      For i = 2 To n - 1 'check same name not within 2
                      If Cells(i, 2) = Cells(i + 1, 2) Or Cells(i, 2) = Cells(i + 2, 2) Then 'do again
                      OK = False
                      Exit For
                      End If
                      Next i
                      iShuf = iShuf + 1
                      Loop Until OK Or iShuf > maxShuf
                      Do
                      'shuffle C
                      For i = 2 To n
                      k = Int(Rnd * (n - 1)) + 2 'random integer from 2 to n
                      s = Cells(k, 3).Value
                      Cells(k, 3).Value = Cells(i, 3).Value
                      Cells(i, 3).Value = s
                      Next i
                      OK = True
                      For i = 2 To n
                      If Cells(i, 2).Value = Cells(i, 3).Value Then 'need to do it again
                      OK = False
                      Exit For
                      ElseIf i < n Then
                      If Cells(i, 3) = Cells(i + 1, 3) Or Cells(i, 3) = Cells(i + 2, 3) Then 'do again
                      OK = False
                      Exit For
                      End If
                      End If
                      Next i
                      iShuf = iShuf + 1
                      Loop Until OK Or iShuf > maxShuf
                      If iShuf > maxShuf Then MsgBox "Sorry, unable to meet the conditions in " & Format(maxShuf, "#,##0") & " shuffles.", vbOKOnly + vbExclamation, "Conditions Not Met"
                      Application.ScreenUpdating = True
                      End Sub
                      Please do not U2U (private message) me directly for questions that should be posted to the forum; any such U2Us will be ignored.

                      Comment


                      • #12
                        Re: Random Draw

                        One more thing that would make this work perfect. There cannot be duplicate teams. So the name in column A can only rope once with the name in column B.

                        Comment


                        • #13
                          Re: Random Draw

                          I am trying to create pairing for a team sort. Each person gets to pick a certain number of teams and draw a certain number.
                          team Name Name
                          1 luanne bridget
                          2 clay trudi
                          3 niki jodi
                          4 george lenard
                          5 trudi
                          6 trudi
                          7 bridget
                          8 clay
                          9 clay
                          10 niki
                          11 niki
                          12 jodi
                          13 george
                          14 lenard
                          15 lenard
                          16
                          So if there is not a teammate in column =c. I need the spreadsheet to give the person teammate but the teams cannot be the same pairs as the ones that they picked. All teams must be unique. It needs to suffle the line up or sort the teams order. And if Luann goes 1st then she can't go again for 5 runs so her horse can rest. I really appreciate the help!! Thanks


                          *EDIT* Thread closed - above is a duplicate of a thread with current replies (http://www.ozgrid.com/forum/showthre...869#post651869)

                          Comment

                          Working...
                          X