VBA/Excel/Access/Word/Access/Index

Adding a Multiple-Field Index to an Existing Table

   <source lang="vb">

Sub Add_MultiFieldIndex()

  Dim conn As New ADODB.Connection
  With conn
     .Provider = "Microsoft.Jet.OLEDB.4.0"
     .Open "Data Source=" & CurrentProject.Path & _
         "\mydb.mdb"
     .Execute "CREATE INDEX Location ON Employees (City, Region);"
  End With
  conn.Close
  Set conn = Nothing
  MsgBox "New index (Location) was created."

End Sub

</source>
   
  

Adding a Single-Field Index to an Existing Table (Intrinsic constants for the IndexNulls property of the ADOX Index object)

   <source lang="vb">

Constant Name Description adIndexNullsAllow create an index if there is a Null value in the index field (an error will not occur). adIndexNullsDisallow (default value)You cannot create an index if there is a Null in the index for the column (an error will occur). adIndexNullsIgnore create an index if there is a Null in the index field (an error will not occur). adIndexNullsIgnoreAny You can create an index if there is a Null value in the index field.

Sub Add_SingleFieldIndex()

  Dim cat As New ADOX.Catalog
  Dim myTable As New ADOX.Table
  Dim myIndex As New ADOX.Index
  On Error GoTo ErrorHandler
  cat.ActiveConnection = CurrentProject.Connection
  Set myTable = cat.Tables("vbexTable")
  With myIndex
     .Name = "idxDescription"
     .Unique = False
     .IndexNulls = adIndexNullsIgnore
     .Columns.Append "Description"
     .Columns(0).SortOrder = adSortAscending
  End With
  myTable.Indexes.Append myIndex
  Set cat = Nothing
  Exit Sub

ErrorHandler:

  If Err.Number = -2147217856 Then
     MsgBox "The "vbexTable" cannot be open.", vbCritical, _
         "Close the table"
  ElseIf Err.Number = -2147217868 Then
     myTable.Indexes.Delete myIndex.Name
     Resume 0
  Else
     MsgBox Err.Number & ": " & Err.Description
  End If

End Sub

</source>
   
  

Adding a Unique Index Based on Two Fields to an Existing Table

   <source lang="vb">

Sub AddMulti_UniqueIndex()

   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, Name" 
   conn.Execute "ALTER TABLE " & strTable & " ADD CONSTRAINT multiIdx UNIQUE(" & strCol & ");" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  

Alter table to delete an Index with SQL command

   <source lang="vb">

Sub DeleteIndex()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   Dim strIdx As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   strIdx = "pKey" 
   conn.Execute "ALTER TABLE " & strTable & " DROP CONSTRAINT " & strIdx & ";" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   MsgBox Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  

Auto-Generate an Index Using VBA

   <source lang="vb">

Private Sub Worksheet_Activate()

    Dim wSheet As Worksheet
    Dim l As Long
    l = 1
    With Me
         .Columns(1).ClearContents
         .Cells(1, 1) = "INDEX"
         .Cells(1, 1).Name = "Index"
    End With
    For Each wSheet In Worksheets
     If wSheet.Name <> Me.Name Then
         l = l + 1
     With wSheet
         .Range("A1").Name = "Start" & wSheet.Index
         .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", SubAddress:= "Index", TextToDisplay:="Back to Index"
     End With
     Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="",SubAddress:="Start" & wSheet.Index, TextToDisplay:=wSheet.Name
     End If
     Next wSheet

End Sub

</source>
   
  

Creating an Index that Disallows Null Values in the Key with SQL command

   <source lang="vb">

Sub Index_WithDisallowNullOption()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   conn.Execute "CREATE INDEX idxSupplierCity ON " & strTable _ 
       & "(SCity) WITH DISALLOW NULL ;" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  

Creating an Index with the Ignore Null Option with SQL command

   <source lang="vb">

Sub Index_WithIgnoreNullOption()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   conn.Execute "CREATE INDEX idxSupplierPhone ON " & strTable & "(SPhone) WITH IGNORE NULL ;" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  

Creating a Primary Key Index with Restrictions with SQL command

   <source lang="vb">

Sub Index_WithPrimaryOption()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   conn.Execute "CREATE INDEX idxPrimary1 ON " & strTable _ 
       & "(SId) WITH PRIMARY ;" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  

Deleting a Field that is a Part of an Index with SQL command

   <source lang="vb">

Sub DeleteIdxField()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   Dim strCol As String 
   Dim strIdx As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   strCol = "myName" 
   strIdx = "multiIdx" 
   conn.Execute "ALTER TABLE " & strTable & " DROP CONSTRAINT " & strIdx & ";" 
   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

</source>
   
  

Deleting an Index with SQL command

   <source lang="vb">

Sub DeleteIndex()

   Dim conn As ADODB.Connection 
   Dim strTable As String 
   On Error GoTo ErrorHandler 
   Set conn = CurrentProject.Connection 
   strTable = "myTable" 
   conn.Execute "DROP INDEX idxSupplierName ON " & strTable & ";" 

ExitHere:

   conn.Close 
   Set conn = Nothing 
   Exit Sub 

ErrorHandler:

   Debug.Print Err.Number & ":" & Err.Description 
   Resume ExitHere 

End Sub

</source>
   
  

Deleting Indexes from a Table

   <source lang="vb">

Sub Delete_Indexes()

  Dim conn As New ADODB.Connection
  Dim cat As New ADOX.Catalog
  Dim myTable As New ADOX.Table
  Dim idx As New ADOX.Index
  Dim count As Integer
  With conn
     .Provider = "Microsoft.Jet.OLEDB.4.0"
     .Open "Data Source=" & CurrentProject.Path & _
         "\mydb.mdb"
  End With
  cat.ActiveConnection = conn

Setup:

  Set myTable = cat.Tables("Employees")
  Debug.Print myTable.Indexes.count
  For Each idx In myTable.Indexes
      If idx.PrimaryKey <> True Then
        myTable.Indexes.Delete (idx.Name)
        GoTo Setup
      End If
  Next idx
  conn.Close
  Set conn = Nothing
  MsgBox "All Indexes but Primary Key were deleted."

End Sub

</source>
   
  

Listing Indexes in a Table

   <source lang="vb">

Sub List_Indexes()

  Dim conn As New ADODB.Connection
  Dim cat As New ADOX.Catalog
  Dim myTable As New ADOX.Table
  Dim idx As New ADOX.Index
  With conn
     .Provider = "Microsoft.Jet.OLEDB.4.0"
     .Open "Data Source=" & CurrentProject.Path & _
         "\mydb.mdb"
  End With
  cat.ActiveConnection = conn
  Set myTable = cat.Tables("Employees")
  For Each idx In myTable.Indexes
    Debug.Print idx.Name
  Next idx
  conn.Close
  Set conn = Nothing
  MsgBox "Indexes are listed in the Immediate window."

End Sub

</source>