VBA/Excel/Access/Word/Access/Table Create

Adding a Single-Field Index to an Existing Table with SQL command

 
Sub SingleField_Index2() 
    Dim conn As ADODB.Connection 
    Dim strTable As String 
    On Error GoTo ErrorHandler 
    Set conn = CurrentProject.Connection 
        strTable = "myTable" 
    conn.Execute "CREATE INDEX idxCity ON " & strTable & "(SCity) ;" 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    MsgBox Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Create a table with validation rule

 
Sub exaCreateTable()
    Dim db As Database
    Dim tblNew As TableDef
    Dim fld As Field
    
    Set db = CurrentDb
    
    Set tblNew = db.CreateTableDef("NewTable")
    Set fld = tblNew.CreateField("NewField", dbText, 100)
    
    fld.AllowZeroLength = True
    fld.DefaultValue = "Unknown"
    fld.Required = True
    fld.ValidationRule = "Instr$(Like "A*" or Like "Unknown""
    fld.ValidationText = "Known value must begin with A"
    tblNew.Fields.Append fld
    db.TableDefs.Append tblNew
End Sub

Creating an Index Based on Two Fields with SQL command

 
Sub MultiField_Index() 
    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), " _ 
        & "SCity CHAR (19), " _ 
        & "CONSTRAINT idxSupplierNameCity UNIQUE " _ 
        & "(SName, SCity));" 
    Application.RefreshDatabaseWindow 
ExitHere: 
        conn.Close 
        Set conn = Nothing 
        Exit Sub 
ErrorHandler: 
        Debug.Print Err.Number & ":" & Err.Description 
        Resume ExitHere 
End Sub

Creating a Table (ADOX data types vs. Microsoft Access data types)

 
 
ADOX Data Type             Corresponding Data Type in Access
adBoolean                  Yes/No
adUnsignedTinyInt          Number (FieldSize = Byte)
adSmalIInt                 Number (FieldSize = Integer)
adSingle                   Number (FieldSize = Single)
adDouble                   Number (FieldSize = Double)
adDecimal                  Number (FieldSize = Decimal)
adInteger                  Number (FieldSize = LongInteger)
AutoNumber
adCurrency                 Currency
adVarWChar                 Text
adDate                     Date/Time
adLongVarBinary            OLE Object
dbMemo                     Memo
adLongVarWChar             Hyperlink 
" make sure to set up a reference to
" the Microsoft ADO Ext. 2.5 for DDL and Security
" Object Library
Sub Create_Table()
   Dim cat As ADOX.Catalog
   Dim myTable As ADOX.Table
   On Error GoTo ErrorHandler
   Set cat = New Catalog
   cat.ActiveConnection = CurrentProject.Connection
   Set myTable = New Table
   With myTable
      .Name = "vbexTable"
      With .Columns
         .Append "Id", adVarWChar, 10
         .Append "Description", adVarWChar, 255
         .Append "Type", adInteger
      End With
   End With
   cat.Tables.Append myTable
   Set cat = Nothing
   MsgBox "The new table "vbexTable" was created."
   Exit Sub
ErrorHandler:
   If Err.Number = -2147217857 Then
      cat.Tables.Delete "vbexTable"
      Resume
   End If
   MsgBox Err.Number & ": " & Err.Description
End Sub

Creating a Table in a New Database with AUTOINCREMENT column

 
Sub CreateTableInNewDb()
    Dim cat As ADOX.Catalog
    Dim conn As ADODB.Connection
    Dim strDb As String
    Dim strTable As String
    Dim strConnect As String
    
    On Error GoTo ErrorHandler
    
    Set cat = New ADOX.Catalog
    strDb = CurrentProject.Path & "\mydb.mdb"
    strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDb
    
    cat.Create strConnect
    
    Set conn = cat.ActiveConnection
    
    conn.Execute "CREATE TABLE myTable(SchoolId AUTOINCREMENT(100, 5)," & _
        "SchoolName CHAR,City Char (25), District Char (35),YearEstablished Date);"
ExitHere:
    Set cat = Nothing
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    If Err.Number = -2147217897 Then
        Kill strDb
        Resume 0
    Else
        Debug.Print Err.Number & ": " & Err.Description
        GoTo ExitHere
    End If
End Sub

Creating a Table in the Current Database with SQL statement

 
Sub CreateTable()
    Dim conn As ADODB.Connection
    Dim strTable As String
    On Error GoTo ErrorHandler
    Set conn = CurrentProject.Connection
    strTable = "Employees"
    conn.Execute "CREATE TABLE " & strTable & _
       "(Id AUTOINCREMENT(100, 5)," & _
       "lName CHAR," & _
       "City Char (25), District Char (35)," & _
       "YearEstablished Date);"
    Application.RefreshDatabaseWindow
ExitHere:
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ":" & Err.Description
    Resume ExitHere
End Sub

Creating a Table with a Single-Field Index with SQL command

 
Sub SingleField_Index()
    Dim conn As ADODB.Connection
    Dim strTable As String
    On Error GoTo ErrorHandler
    Set conn = CurrentProject.Connection
    strTable = "myTable"
    conn.Execute "CREATE TABLE " & strTable _
        & "(Id INTEGER, " _
        & "SName CHAR (30), " _
        & "CONSTRAINT idxSupplierName UNIQUE " _
        & "(SName));"
    Application.RefreshDatabaseWindow
ExitHere:
        conn.Close
        Set conn = Nothing
        Exit Sub
ErrorHandler:
        Debug.Print Err.Number & ":" & Err.Description
        Resume ExitHere
End Sub

Creating Check Constraints:add business rules for a table

 
Sub CreateCheckConstraint()
    Dim cmd As ADODB.rumand
    Set cmd = New ADODB.rumand
    cmd.ActiveConnection = CurrentProject.Connection
    cmd.rumandText = "CREATE TABLE Customers1 " & _
        "(CustomerID LONG CONSTRAINT CustomerID PRIMARY KEY, " & _
        "CompanyName TEXT (50), IntroDate DATETIME, " & _
        "CONSTRAINT IntroDateCheck CHECK (IntroDate <= Date()), " & _
        "CreditLimit CURRENCY DEFAULT 5000)"
    cmd.Execute
End Sub

Default Column value

 
Sub CreateDefault()
    Dim cmd As ADODB.rumand
    Set cmd = New ADODB.rumand
    cmd.ActiveConnection = CurrentProject.Connection
    cmd.rumandText = "CREATE TABLE Customers " & _
        "(CustomerID LONG CONSTRAINT CustomerID PRIMARY KEY, " & _
        "CompanyName TEXT (50), IntroDate DATETIME, " & _
        "CreditLimit CURRENCY DEFAULT 5000)"
    cmd.Execute
End Sub