VBA/Excel/Access/Word/Access/Index

Adding a Multiple-Field Index to an Existing Table

 
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

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

 
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

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

 
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

Alter table to delete an Index with SQL command

 
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

Auto-Generate an Index Using VBA

 
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

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

 
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

Creating an Index with the Ignore Null Option with SQL command

 
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

Creating a Primary Key Index with Restrictions with SQL command

 
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

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

 
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

Deleting an Index with SQL command

 
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

Deleting Indexes from a Table

 
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

Listing Indexes in a Table

 
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