Do you want to add ALL the tables, or have the option of
typing in ONLY the table names you want to combine?

Option Compare Database

Public Sub CombineAllTables()
On Error GoTo Err_CombineTables

    Dim dbs As Database
    Dim tdfNewTable As TableDef, tdfExistingTable As
TableDef
    Dim fldToAppend As Field, fldNewField As Field,
fldDuplicate As Field
    Dim OKtoAddField As Boolean

    Dim stNewTable As String

    Set dbs = CurrentDb                         ' set the
current database

    stNewTable = "MyNewTable"
    Set tdfNewTable = dbs.CreateTableDef(stNewTable)

    For Each tdfExistingTable In dbs.TableDefs  'Each Table
        If Left(tdfExistingTable.Name, 4) = "MSys" Then
GoTo Next_Table ' ignore these system tables
        Debug.Print tdfExistingTable.Name
        For Each fldToAppend In
tdfExistingTable.Fields  'Each Field in the existing
table ...
            With fldToAppend
                OKtoAddField = True
                Debug.Print .Name
                For Each fldDuplicate In
tdfNewTable.Fields ' Check to make sure it's not a
duplicate
                    If fldToAppend.Name =
fldDuplicate.Name Then OKtoAddField = False
                Next
                If OKtoAddField Then        ' if not a
duplicate it field name then add it
                    Set fldNewField =
tdfExistingTable.CreateField(.Name, .Type, .Size)
                    tdfNewTable.Fields.Append fldNewField
                End If
            End With
        Next
Next_Table:
    Next
    dbs.TableDefs.Append tdfNewTable    ' Append the new
table to the tabledefs collection
    dbs.TableDefs.Refresh               'refresh the
tabledefs

Exit_Sub:

    Exit Sub

Err_CombineTables:
    MsgBox Err.Description
    GoTo Exit_Sub
End Sub