VBA/Excel/Access/Word/Access/Primary Key

Adding a Primary Key to a Table with SQL command

 
Sub AddPrimaryKey() 
    Dim conn As ADODB.Connection 
    Dim strTable As String 
    Dim strCol As String 
    On Error GoTo ErrorHandler 
    Set conn = CurrentProject.Connection 
    strTable = "myTable" 
    strCol = "Id" 
    conn.Execute "ALTER TABLE " & strTable & " ADD CONSTRAINT pKey PRIMARY KEY(" & strCol & ");" 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    Debug.Print Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Create a primary key

 
Sub ADOCreatePrimaryKey()
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim pk As New ADOX.Key
    
    cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=C:\mydb.mdb;"
    
    Set tbl = cat.Tables("Newtable")
    pk.Name = "PrimaryKey"
    pk.Type = adKeyPrimary
    pk.Columns.Append "Column1"
    tbl.Keys.Append pk
End Sub

Creating a Primary Key

 
Sub Create_PrimaryKey()
   Dim cat As New ADOX.Catalog
   Dim myTable As New ADOX.Table
   Dim pKey As New ADOX.Key
   On Error GoTo ErrorHandler
   cat.ActiveConnection = CurrentProject.Connection
   Set myTable = cat.Tables("vbexTable")
   With pKey
      .Name = "PrimaryKey"
      .Type = adKeyPrimary
   End With
   pKey.Columns.Append "Id"
   myTable.Keys.Append pKey
   Set cat = Nothing
   Exit Sub
ErrorHandler:
   If Err.Number = -2147217856 Then
      MsgBox "The "vbexTable" is open.", _
          vbCritical, "Please close the table"
   ElseIf Err.Number = -2147217767 Then
      myTable.Keys.Delete pKey.Name
      Resume
   Else
      MsgBox Err.Number & ": " & Err.Description
   End If
End Sub

Creating a Single-Field Primary Key with SQL command

 
Sub SingleField_PKey()
    Dim conn As ADODB.Connection
    Dim strTable As String
    On Error GoTo ErrorHandler
    Set conn = CurrentProject.Connection
    strTable = "myTable"
    conn.Execute "CREATE TABLE " & strTable _
        & "(SId INTEGER, " _
        & "SName CHAR (30), " _
        & "CONSTRAINT idxPrimary PRIMARY KEY " _
        & "(SId));"
    Application.RefreshDatabaseWindow
ExitHere:
        conn.Close
        Set conn = Nothing
        Exit Sub
ErrorHandler:
        MsgBox Err.Number & ":" & Err.Description
        Resume ExitHere
End Sub