VBA/Excel/Access/Word/Access/Table Column Field

Adding a Field with SQL command

 
Sub ADOAddField()
    Dim cnn As ADODB.Connection
    Dim cmd As ADODB.rumand
    MyConn = "C:\mydb.mdb"
    End If
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
   Set cmd = New ADODB.rumand
   Set cmd.ActiveConnection = cnn
   cmd.rumandText = "ALTER TABLE tbl1 Add Column Grp Char(25)"
   cmd.Execute , , adCmdText
   Set cmd = Nothing
   Set cnn = Nothing
End Sub

Adding a New Field to a Table

 
Sub Add_NewFields()
   Dim cat As New ADOX.Catalog
   Dim myTable As New ADOX.Table
   Set cat = New ADOX.Catalog
   cat.ActiveConnection = CurrentProject.Connection
   cat.Tables("vbexTable").Columns.Append _
       "MyNewField", adWChar, 15
   Set cat = Nothing
End Sub

Adding a New Money type Field to an Existing Table

 
Sub AddNewField()
    Dim conn As ADODB.Connection
    Dim strTable As String
    Dim strCol As String
    On Error GoTo ErrorHandler
    Set conn = CurrentProject.Connection
    strTable = "myTable"
    strCol = "newColumn"
    conn.Execute "ALTER TABLE " & strTable & " ADD COLUMN " & strCol & " MONEY;"
ExitHere:
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    Debug.Print Err.Number & ":" & Err.Description
    Resume ExitHere
End Sub

Append new columns to new table

 
Sub CreateTable()
    
    Dim cat As New ADOX.Catalog
    Dim tbl As New ADOX.Table
    
    cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=C:\mydb.mdb;"
    
    " Assign table name and some columns
    With tbl
       .Name = "NewTable"
       .Columns.Append "Column1", adVarWChar, 250
       .Columns.Append "Column2", adInteger
       .Columns.Append "Column3", adInteger
    End With
    
    cat.Tables.Append tbl
End Sub

Changing the Field Data Type with SQL command

 
Sub ChangeFieldType() 
    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 & " ALTER COLUMN " & strCol & " CHAR(15);" 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    MsgBox Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Changing the Size of a Field with SQL command

 
Sub ChangeFieldSize() 
    Dim conn As ADODB.Connection 
    Dim strTable As String 
    Dim strCol As String 
    On Error GoTo ErrorHandler 
    Set conn = CurrentProject.Connection 
    strTable = "myTable" 
    strCol = "Name" 
conn.Execute "ALTER TABLE " & strTable & " ALTER COLUMN " & strCol & " CHAR(40);" 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    Debug.Print Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Changing the Start (Seed) Value of the AutoNumber Field with SQL command

 
Sub ChangeAutoNumber() 
    Dim conn As ADODB.Connection 
    Dim strDb As String 
    Dim strConnect As String 
    Dim strTable As String 
    Dim strCol As String 
    Dim intSeed As Integer 
    On Error GoTo ErrorHandler 
    strDb = CurrentProject.Path & "\" & "mydb.mdb" 
    strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & strDb 
    strTable = "myTable" 
    strCol = "Id" 
    intSeed = 1000 
    Set conn = New ADODB.Connection 
    conn.Open strConnect 
    conn.Execute "ALTER TABLE " & strTable & " ALTER COLUMN " & strCol & " COUNTER (" & intSeed & ");" 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    If Err.Number = -2147467259 Then 
        Debug.Print "The database file cannot be located.", _ 
            vbCritical, strDb 
        Exit Sub 
    Else 
        Debug.Print Err.Number & ":" & Err.Description 
        Resume ExitHere 
    End If 
End Sub

Checking for Existence of a Field

 
Function ColumnExists(WhichColumn, WhichTable)
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim WSOrig As Worksheet
    Dim WSTemp As Worksheet
    Dim fld As ADODB.Field
    ColumnExists = False
    MyConn = MyConn & "\mydb.mdb"
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
    Set rst = cnn.OpenSchema(adSchemaColumns)
    Do Until rst.EOF
        If LCase(rst!Column_Name) = LCase(WhichColumn) And _
           LCase(rst!Table_Name) = LCase(WhichTable) Then
            ColumnExists = True
            GoTo ExitMe
        End If
        rst.MoveNext
    Loop
ExitMe:
    rst.Close
    Set rst = Nothing
    cnn.Close
End Function

Delete a column

 
Sub ChangeColumn()
    Dim cat As New ADOX.Catalog
    Dim tbl As New ADOX.Table
    
    cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=C:\mydb.mdb;"
    Set tbl = cat.Tables("Newtable")
    tbl.Columns("Column2").Name = "Column2X"
    tbl.Columns.Delete "Column3"
End Sub

Deleting a Field from a Table with SQL command

 
Sub DeleteField() 
    Dim conn As ADODB.Connection 
    Dim strTable As String 
    Dim strCol As String 
    On Error GoTo ErrorHandler 
    Set conn = CurrentProject.Connection 
    strTable = "myTable" 
    strCol = "myCol" 
    conn.Execute "ALTER TABLE " & strTable & " DROP COLUMN " & strCol & ";" 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    Debug.Print Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Get field properties

 
Public Sub DescribeARow()
  Const SQL As String = "SELECT * FROM Customers"
  Const ConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\mydb.mdb;Persist Security Info=False"
  Dim Recordset As Recordset
  Set Recordset = New Recordset
  Call Recordset.Open(SQL, ConnectionString, adOpenDynamic)
  Recordset.MoveFirst
  Dim Field As Field
  For Each Field In Recordset.Fields
    Debug.Print "Name: " & Field.Name
    Debug.Print "Type: " & Field.Type
    Debug.Print "Size: " & Field.ActualSize
    Debug.Print "Value: " & Field.Value
  Next
End Sub

Listing Field Properties

 
Sub List_FieldProperties()
   Dim cat As ADOX.Catalog
   Dim col As ADOX.Column
   Dim pr As ADOX.Property
   Set cat = New ADOX.Catalog
   Set cat.ActiveConnection = CurrentProject.Connection
   Set col = New ADOX.Column
   Set col = cat.Tables("vbexTable").Columns("Id")
   MsgBox col.Properties.Count
   For Each pr In col.Properties
      Debug.Print pr.Name & "="; pr.Value
   Next
   Set cat = Nothing
End Sub

Listing Tables and Their Fields Using the OpenSchema Method

 
Sub ListTblsAndFields()
   Dim conn As ADODB.Connection
   Dim rst As ADODB.Recordset
   Dim curTable As String
   Dim newTable As String
   Dim counter As Integer
   Set conn = New ADODB.Connection
   conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\mydb.mdb"
   Set rst = conn.OpenSchema(adSchemaColumns)
   curTable = ""
   newTable = ""
   counter = 1
   Do Until rst.EOF
      curTable = rst!table_Name
      If (curTable <> newTable) Then
         newTable = rst!table_Name
         Debug.Print "Table: " & rst!table_Name
         counter = 1
      End If
      Debug.Print "Field" & counter & ": " & rst!Column_Name
      counter = counter + 1
      rst.MoveNext
   Loop
   rst.Close
   conn.Close
   Set rst = Nothing
   Set conn = Nothing
End Sub

Open a table and read data by column

 
Sub LoopProjects()
    Dim rst As ADODB.Recordset
    Set rst = New ADODB.Recordset
    rst.Open "Employees", CurrentProject.Connection
    Do Until rst.EOF
        Debug.Print rst!Title, rst!City
        If IsNull(rst!Region) Then
            Debug.Print "No Value!!"
        End If
        rst.MoveNext
    Loop
End Sub

Read record in recordset by referening the field name with "!"

 
Public Sub Loops()
    Dim con As ADODB.Connection
    Dim rs As New ADODB.Recordset
    Set con = New ADODB.Connection
    
    con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\store.mdb;"
    
    rs.CursorLocation = adUseServer
    rs.Open "SELECT * FROM Employees", con, adOpenStatic, adLockOptimistic
    
    Do While Not rs.EOF
        Dim strName As String
        Debug.Print rs!txtCustFirstName & " " & rs!txtCustLastName
        rs.MoveNext
    Loop
    Debug.Print rs.RecordCount & " records: "
   
    Set rs = Nothing
    Set con = Nothing
End Sub

Read specific columns from Recordset

 
Sub MyFirstConnection()
    Dim myConnection As ADODB.Connection
    Dim myRecordset As ADODB.Recordset
    Dim strSQL As String
   
    strSQL = "SELECT FirstName, LastName FROM Employees"
    
    Set myConnection = CurrentProject.Connection
    
    Set myRecordset = New ADODB.Recordset
    myRecordset.Open strSQL, myConnection
    
    Do Until myRecordset.EOF
       Debug.Print myRecordset.Fields("FirstName") & " " & myRecordset.Fields("LastName")
       myRecordset.moveNext
    Loop
    myRecordset.Close
    myConnection.Close
    Set myConnection = Nothing
    Set myRecordset = Nothing
End Sub

Removing a Field from a Table

 
Sub Delete_Field()
   Dim cat As New ADOX.Catalog
   Set cat = New ADOX.Catalog
   cat.ActiveConnection = CurrentProject.Connection
   cat.Tables("vbexTable").Columns.Delete "Type"
   Set cat = Nothing
End Sub

Set column properties by using ADOX.Table

 
ADO Equivalents to Access Data Types
 
Microsoft Access Data Type     ADO Equivalent
Binary                         adBinary
Boolean                        adBoolean
Byte                           adUnsignedTinyInt
Currency                       adCurrency
Date                           adDate
Numeric                        adNumeric
Double                         adDouble
Small Integer                  adSmallInt
Integer                        adInteger
Long Binary                    adLongBinary
Memo                           adLongVarWChar
Single                         adSingle
Text                           adWChar

Sub makeTable()
   Dim currCat As New ADOX.Catalog
   Dim newTable As New ADOX.Table
   Dim newKey As New ADOX.Key
   
   currCat.ActiveConnection = CurrentProject.Connection
   
   With newTable
      .Name = "tblTestTable"
      .Columns.Append "custNumber", adInteger
      .Columns("custNumber").ParentCatalog = currCat
      .Columns("custNumber").Properties("AutoIncrement") = True
      
      newKey.Name = "PrimaryKey"
      newKey.Columns.Append "custNumber"
      .Keys.Append newKey, adKeyPrimary
      
      .Columns.Append "custFirstName", adWChar
      .Columns.Append "custLastName", adWChar
     End With
     
     currCat.Tables.Append newTable
     
     Set currCat = Nothing
End Sub

Setting a Default Value for a Field with SQL command

 
Sub SetDefaultFieldValue() 
    Dim conn As ADODB.Connection 
    Dim strTable As String 
    Dim strCol As String 
    Dim strDefVal As String 
    Dim strSQL As String 
    On Error GoTo ErrorHandler 
    Set conn = CurrentProject.Connection 
    strTable = "myTable" 
    strCol = "City" 
    strDefVal = "Boston" 
    strSQL = "ALTER TABLE " & strTable & _ 
        " ALTER " & strCol & " SET DEFAULT " & strDefVal 
    conn.Execute strSQL 
ExitHere: 
    conn.Close 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    Debug.Print Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Show field name, type and value data type

 
Sub rec_fields()
  Dim conn As New Connection
  Dim rec As New Recordset
  Dim f As Field
  Dim ws As Worksheet
  Dim i&
  Set ws = ThisWorkbook.Worksheets("fields")
  conn.Open "Provider=microsoft.jet.oledb.4.0;" + _
    "Data Source=" + ThisWorkbook.Path + "\nwind.mdb;"
  rec.Open "employees", conn
  For Each f In rec.Fields
    i = i + 1
    ws.[a1].Cells(i) = f.Name
    ws.[b1].Cells(i) = f.Type
    ws.[c1].Cells(i) = TypeName(f.Value)
  Next
  rec.Close: conn.Close
End Sub