Results 1 to 9 of 9

Thread: Secret Santa dB

  1. #1
    Join Date
    May 2005
    Posts
    1,191

    Unanswered: Secret Santa dB

    So every year our family does a gift exchange around Christmas time with each other. Everyone is assigned to get a gift for someone else. Two rules: (1) it has to be a one-to-one relationship; no person can get two gifts, or give two gifts, and (2) you can't have the name of anyone in your family (including yourself); this makes shopping easier when you don't have to secretly shop for your wife or whatever.

    We used to pull names out of a hat, but now my nearest relative lives about 800 miles away (in another country in fact). And about the only time we get together is FOR Christmas, so we can't draw names then. So I volunteered to build a dB to randomly assign the names and email them out, so that (a) it's completely random, and (b) not even I know who everyone has and it's a surprise for everyone.

    I have attached a dB (it's been generalized) that in theory works. However, it simply keeps choosing random names till it happens to pick a combo that fulfills both rules as stated above for every name. You can about imagine the probability of this happening.

    So what I'm looking for is any tips on how to make the name assignment portion of the code more efficient. I've tried to run it for my family (with 15 individuals belonging to 6 families), and it's run for about 5 min before I ctl+break'd the code (thanks pbaldy). Any ideas? Keeping in mind I'm trying to keep this flexible so as more people are added to the family, I don't have to go in and remember how to add a person.
    Attached Files Attached Files
    Me.Geek = True

  2. #2
    Join Date
    Sep 2003
    Location
    MI
    Posts
    3,713
    Rules and pools ...

    Have each member be set into a Family Group (ID?)
    Have the record have 2 flags: GiveTo and ReceiveFrom (or whatever you want to call them)

    Run your process for each family group where you query for all members NOT in that group AND have not been assigned a secret santa. THen randomly pick the member from that pool ... Assign the IDs of those 2 menmbers to each other ... You can even randomly pick the member from the family group to perform the secret santa selection on ...
    Back to Access ... ADO is not the way to go for speed ...

  3. #3
    Join Date
    May 2005
    Posts
    1,191
    Quote Originally Posted by M Owen
    Have each member be set into a Family Group (ID?)
    Have the record have 2 flags: GiveTo and ReceiveFrom (or whatever you want to call them)
    Already did this in the above attachment
    Quote Originally Posted by M Owen
    Run your process for each family group where you query for all members NOT in that group AND have not been assigned a secret santa. THen randomly pick the member from that pool ... Assign the IDs of those 2 menmbers to each other ... You can even randomly pick the member from the family group to perform the secret santa selection on ...
    How would you do this programatically?
    Also, what happens if you get to the last person in the list, and the only choice they have left from the "pool" is someone in their family? Would you restart the whole thing? Or is there a way to guarantee this doesn't happen?

    I have since found two ways of improving speed; (1) I changed the tag property to cut down on IF checks and now check the ctl's name property for the giver, and (2) I inserted/changed the following 2 lines of code in red:
    Code:
    Private Sub CmdBtnAssign_Click()
    
    On Error GoTo Err_CmdBtnAssign_Click
    
    DoCmd.Hourglass True
    DoCmd.Echo False
    
    Dim strTimeStart As String
    strTimeStart = Now
    
    'Find total number of people
    Dim intCount As Long
    intCount = DCount("*", "TblNames")
    
    'Get names and store in text boxes
    Dim strGiver As String, strReciever As String, strRecordText As String, _
        intGiverFamily As Integer, intRecieverFamily As Integer
    Dim ctl As Control, ctlcheck As Control
    RestartAssignment:
    'Reset the boxes to zls's
    For Each ctl In Form.Controls
        If ctl.Tag = "Assign" Then
            ctl = ""
        End If
    Next
    strGiver = ""
    strReciever = ""
    For Each ctl In Form.Controls
        If ctl.Tag = "Assign" Then
            strGiver = ctl.Name
            'Assign random person
    PickAnother:
            Randomize
            strReciever = Nz(DLookup("[FldName]", "TblNames", "[FldID] = " & Int(Rnd() * (intCount))), "")
            ctl = strReciever
            'Check to see not in the same family or self
            intGiverFamily = DLookup("[FldFamily]", "TblNames", "[FldName] = '" & strGiver & "'")
            intRecieverFamily = DLookup("[FldFamily]", "TblNames", "[FldName] = '" & strReciever & "'")
            If intGiverFamily = intRecieverFamily Then
                GoTo PickAnother
            End If
            'check to see not already taken
            For Each ctlcheck In Form.Controls
                If ctlcheck.Tag = "Assign" Then
                    If ctl.Name <> ctlcheck.Name Then 'make sure not checking itself
                        If strReciever = Nz(ctlcheck, "") Then 'make sure not taken
                            GoTo RestartAssignment
                        End If
                    End If
                End If
            Next
        End If
    Next
    
    'build record string
    Dim strEmailAddress As String
    strRecordText = "Christmas Name Assignments " & Format(Date, "yyyy") & vbNewLine & _
                    "Started: " & strTimeStart & vbNewLine & _
                    "Created: " & Now & vbNewLine & _
                    "Time to assign (minutes): " & DateDiff("s", strTimeStart, Now) / 60 & vbNewLine & vbNewLine
    For Each ctl In Form.Controls
        If ctl.Tag = "Assign" Then
            strGiver = ctl.Name
            strReciever = ctl
            strEmailAddress = Nz(DLookup("[FldEmail]", "TblNames", "[FldName] = '" & strGiver & "'"), "")
            strRecordText = strRecordText & vbNewLine & _
                            Format(strGiver, "@@@@@@@@@@@@@@@") & _
                            "  has to get a gift for  " & _
                            Format(strReciever, "!@@@@@@@@@@@@@@@") & _
                            "  and was emailed to  " & _
                            strEmailAddress
        End If
    Next
    strRecordText = strRecordText & vbNewLine & vbNewLine & vbNewLine
    
    'Write names to file for a record
    Dim strFileName As String, strFileLocation As String
    strFileLocation = Application.CurrentProject.Path
    strFileName = "Christmas Names " & Format(Date, "yyyy") & ".txt"
    strFileAddress = strFileLocation & "\" & strFileName
    Dim fs, txtfile As Object, blnFileExists As Boolean
        Set fs = CreateObject("Scripting.FileSystemObject")
        blnFileExists = fs.FileExists(strFileAddress)
        If Not blnFileExists Then
            Set txtfile = fs.CreateTextFile(strFileAddress, True)
            txtfile.Close
        End If
        Set txtfile = fs.OpenTextFile(strFileAddress, 8, -2)
        txtfile.Write (strRecordText)
        txtfile.Close
    
    'Email each person with info
    If Me.chkboxEmail = True Then
        Dim strSubject As String, strMessage As String
        strSubject = "Chirstmas Gifts " & Format(Date, "yyyy")
        For Each ctl In Form.Controls
            If ctl.Tag = "Assign" Then
                strMessage = Me.TxtBoxMessage & vbNewLine & vbNewLine & _
                                "This year you, " & ctl.Name & ", must get a gift for " & ctl & "."
                strEmailAddress = Nz(DLookup("[FldEmail]", "TblNames", "[FldName] = '" & ctl.Name & "'"), "")
                DoCmd.SendObject , , , strEmailAddress, , , strSubject, strMessage, False
            End If
        Next
    End If
    
    'close out
    DoCmd.Close acForm, "FrmAssign", acSaveNo
    MsgBox "A record has been saved at " & vbNewLine & strFileAddress, vbInformation, "File Saved"
    
    Exit_CmdBtnAssign_Click:
        DoCmd.Hourglass False
        DoCmd.Echo True
        Exit Sub
    
    Err_CmdBtnAssign_Click:
        DoCmd.Hourglass False
        DoCmd.Echo True
        MsgBox "error"
        Resume Exit_CmdBtnAssign_Click
        
    End Sub
    Me.Geek = True

  4. #4
    Join Date
    Sep 2003
    Location
    MI
    Posts
    3,713
    Quote Originally Posted by nckdryr
    How would you do this programatically?
    Also, what happens if you get to the last person in the list, and the only choice they have left from the "pool" is someone in their family? Would you restart the whole thing? Or is there a way to guarantee this doesn't happen?
    Well what I'd do it iterate on a list of groups ... To combat the chance of being left "in the family" ... Try processing the groups from largest to smallest. Now one thing you need to check for is an odd # of members overall ...

    When you process from largest to smallest, the smallest group has the best chance to have all members be satisfied without being left stuck with a family member ...
    Back to Access ... ADO is not the way to go for speed ...

  5. #5
    Join Date
    Nov 2004
    Location
    out on a limb
    Posts
    13,692
    Provided Answers: 59
    Im in touch with my feminine side: personally Id fake it and not bother trying to set up a db to do that.
    I'd rather be riding on the Tiger 800 or the Norton

  6. #6
    Join Date
    Dec 2002
    Location
    Préverenges, Switzerland
    Posts
    3,740
    here's a go at it - see frmNew.

    primitive code (domain aggregate as loop control AND a goto!!) and not 100% effective (see how many times family 1 ends up buying for family 3).
    however it always finds a solution in a second or three.

    izy
    Attached Files Attached Files
    currently using SS 2008R2

  7. #7
    Join Date
    May 2005
    Posts
    1,191
    Here's my working example. It only takes a couple of seconds. Anyone can use this, just make sure your table ID's are zero-based and are sequential. That's all it takes. It'll create a text file in the same folder as you put the database, just read that when you're done.
    Attached Files Attached Files
    Me.Geek = True

  8. #8
    Join Date
    Feb 2004
    Posts
    137
    Quote Originally Posted by nckdryr
    So every year our family does a gift exchange around Christmas time with each other. Everyone is assigned to get a gift for someone else. Two rules: (1) it has to be a one-to-one relationship; no person can get two gifts, or give two gifts, and (2) you can't have the name of anyone in your family (including yourself); this makes shopping easier when you don't have to secretly shop for your wife or whatever.
    So apparently we love to begin topics of conversation with transitional words like "so", don't we?


    That aside, lets examine the two rules stated above, and consider the following scenario:

    Family 1 | Member 1
    Family 1 | Member 2
    Family 1 | Member 3
    Family 1 | Member 4
    Family 1 | Member 5

    Family 2 | Member 1
    Family 2 | Member 2
    Family 2 | Member 3

    The three members of Family 2 would have no trouble in being assigned a randomly selected member of Family 1. However, only three of the members of Family 1 would each be assigned a randomly selected member of Family 2. The remaining two members of Family 1 would be stuck with each other. Thus it would not be possible to enforce Rule 2.

    How should that scenario be addressed?

  9. #9
    Join Date
    May 2005
    Posts
    1,191
    Maybe you can just do a completely random assignment and remove the family check. But I'm gonna go with healdem on this and so, that's for someone with that specific problem to address. All I know is I got it working for my situation.
    Me.Geek = True

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •