Option Compare Database 
Option Explicit 
 
Sub ListTablesAndFields() 
     'Macro Purpose:  Write all table and field names to and Excel file
     
    Dim lTbl As Long 
    Dim lFld As Long 
    Dim dBase As Database 
    Dim xlApp As Object 
    Dim wbExcel As Object 
    Dim lRow As Long 
     
     'Set current database to a variable adn create a new Excel instance
    Set dBase = CurrentDb 
    Set xlApp = CreateObject("Excel.Application") 
    Set wbExcel = xlApp.workbooks.Add 
     
     'Set on error in case there is no tables
    On Error Resume Next 
     
     'Loop through all tables
    For lTbl = 0 To dBase.TableDefs.Count 
         'If the table name is a temporary or system table then ignore it
        If Left(dBase.TableDefs(lTbl).Name, 1) = "~" Or _ 
        Left(dBase.TableDefs(lTbl).Name, 4) = "MSYS" Then 
             '~ indicates a temporary table
             'MSYS indicates a system level table
        Else 
             'Otherwise, loop through each table, writing the table and field names
             'to the Excel file
            For lFld = 1 To dBase.TableDefs(lTbl).Fields.Count -1 
                lRow = lRow + 1 
                With wbExcel.sheets(1) 
                    .range("A" & lRow) = dBase.TableDefs(lTbl).Name 
                    .range("B" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Name 
                End With 
            Next lFld 
        End If 
    Next lTbl 
     'Resume error breaks
    On Error Goto 0 
     
     'Set Excel to visible and release it from memory
    xlApp.Visible = True 
    Set xlApp = Nothing 
    Set wbExcel = Nothing 
     
     'Release database object from memory
    Set dBase = Nothing 
     
End Sub