With ThisWorkbook
        On Error Resume Next
     
            .Connections("название вашей связи").Delete
            .Queries("название вашего запроса").Delete '''не обязательно, но для спокойствия души
            
        On Error GoTo 0
        
        .Queries.Add Name:="название вашей связи", Formula:= "ваша query формула"   
        .Connections.Add2 "добавляете реквизиты отталкиваясь от запроса строкой выше"
    End With

Sub addToDataModel(m As Excel.Model, fkTable, fkColumn, pkTable, pkColumn)
    Dim pkTbl As ModelTable
    Dim fkTbl As ModelTable
    Dim fkCol As ModelTableColumn
    Dim pkCol As ModelTableColumn

    DoEvents
    
    Set pkTbl = m.ModelTables(pkTable)
    Set fkTbl = m.ModelTables(fkTable)
    Set fkCol = fkTbl.ModelTableColumns(fkColumn)
    Set pkCol = pkTbl.ModelTableColumns(pkColumn)
    
    m.ModelRelationships.Add _
        ForeignKeyColumn:=fkCol, _
        PrimaryKeyColumn:=pkCol
    Application.StatusBar = False
End Sub

Sub addQueryToDataModel()
   Dim md As Model

   Set md = ThisWorkbook.Model
   addToDataModel md, "Таблица1 "Ключ1", _
                        "Таблица2", "Ключ2"
''' Далее повторяем для всех связей с другими названиями (это понятно)
   addToDataModel md, "Таблица1 "Ключ1", _
                        "Таблица2", "Ключ2"
End sub