Thread: VBA code, One to Many relationships

I want to create a relationship between tblEmpNames to Many tables with the prefix "Weekof" I have code already that will get me the name tables and the code I have creates relationships for a one-to-one relationship just fine. But I need a one-to-many vba macro.

Just so you can see what I have already. Not sure if anyone can just tag the one-to-many code below this code.

Public Function CreateRelationship() As Boolean
    Dim db                  As DAO.Database
    Dim tdf()               As DAO.TableDef
    Dim rels                As DAO.Relations
    Dim rel                 As DAO.Relation
    Dim obj                 As AccessObject
    Dim dbs                 As Object
    Dim intCounter          As Integer
    Dim arrTableNames       As String
    Dim r                   As Long
    Dim TableNames()        As String
    Dim CountTables         As Variant
    Dim OutPutTblNmes          As String
    
Set dbs = Application.CurrentData

    With CountTables
        For Each obj In dbs.AllTables
            If Not Left(obj.Name, 4) = "Msys" Then
            If Left(obj.Name, 6) = "Weekof" Or obj.Name = "tblEmpNames" Then
                r = r + 1
            End If
            End If
        Next obj
    End With
    
    ReDim TableNames(1 To r)
    ReDim tdf(1 To r)

    With CountTables
        For Each obj In dbs.AllTables
            If Not Left(obj.Name, 4) = "Msys" Then
            If Left(obj.Name, 6) = "Weekof" Or obj.Name = "tblEmpNames" Then
                intCounter = intCounter + 1
                TableNames(intCounter) = obj.Name
            End If
            End If
        Next obj
    End With
    

'With CountTables
 '   For Each obj In dbs.AllTables
  '          If Not Left(obj.Name, 4) = "Msys" Then
   '             TableNames(intCounter) = obj.Name
    '        End If
    'Next obj
'End With

OutPutTblNmes = TableNames(1) & Chr(10) & TableNames(2) & Chr(10) & TableNames(3) & Chr(10) & TableNames(4)

'MsgBox OutPutTblNmes
 
    Set db = currentdb
    Set tdf(1) = db.TableDefs(TableNames(r - 1))
    Set tdf(2) = db.TableDefs(TableNames(r))
    Set tdf(3) = db.TableDefs("tblEmpNames")
    Set rels = db.Relations
     
    For Each rel In rels
        If rel.Name = "myRelationship" Then
            rels.Delete ("myRelationship")
        End If
    Next
     
    Set rel = db.CreateRelation("myRelationship", tdf(1).Name, tdf(2).Name, dbRelationUpdateCascade)
     
    rel.Fields.Append rel.CreateField("EmployeeID")
    rel.Fields("EmployeeID").ForeignName = "EmployeeID"
    rels.Append rel
    
    Set rels = Nothing

    'Set tdf = Nothing
    Set tdf2 = Nothing
    Set db = Nothing
    
     
End Function