Sub ExtractAtts_With_Filters() 
  
  Dim Xl As Excel.Application
  Dim XlSheet As Object
  Dim XlWorkbook As Object
  
  Dim RowNum As Integer
  Dim Header As Boolean
  Dim elem As AcadEntity
  Dim Array1 As Variant
  Dim count As Integer
  Dim blk As AcadBlockReference
 

    '****************************************************
    'Delete the .xls Attribute Report File
    Dim KillFile As String
    varPath = ThisDrawing.Path

    On Error GoTo Exit_XL_App
    KillFile = varPath & "\" & "Attribute.xls"
    
    'Check that file exists
    If Len(Dir$(KillFile))  0 Then
        'First remove readonly attribute, if set
        SetAttr KillFile, vbNormal
        'Then delete the file
         Kill KillFile
    End If

    
    
    ' Launch Excel and Get Attributes***************************.
     Set Xl = New Excel.Application
     Xl.Visible = True
    
     ' Create a new workbook and find the active sheet.
     Set XlWorkbook = Xl.Workbooks.Add
     Set XlSheet = Xl.ActiveSheet
     XlWorkbook.SaveAs fileName:=varPath & "\" & "Attribute.xls", FileFormat:=1
     
     RowNum = 1
     Header = False
    
     ' Iterate through model space finding
     ' all block references.
     For Each elem In ThisDrawing.ModelSpace
       With elem
         ' When a block reference has been found,
         ' check it for attributes
         If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
           If .HasAttributes Then
             ' Get the attributes
             Array1 = .GetAttributes
            
            
 
            ' Filter through a list of attribute tagstrings in the current block.
            ' Cycle throught the list of attributes.
            For i = LBound(Array1) To UBound(Array1)
              ' Check for the correct attribute tag.
              Dim Attrib As AcadAttributeReference
              Set Attrib = Array1(i)
              ' If the Tagstring containd "Addresses" then
              ' Copy the Tagstrings into Excel
              If Attrib.TagString = "ADDRESS" Then

 
 
                 ' Copy the Tagstrings for the
                 ' Attributes into Excel
                 For count = LBound(Array1) To UBound(Array1)
                   If Header = False Then
                     If StrComp(Array1(count).EntityName, "AcDbAttribute", 1) = 0 Then
                       XlSheet.Range("A1") = "HANDLE" 'Code below adds column names
                       XlSheet.Cells(RowNum, count + 2).value = Array1(count).TagString
        
                     End If
                   End If
        
                 Next count
        
                 RowNum = RowNum + 1
                 For count = LBound(Array1) To UBound(Array1)
                   If XlSheet.Range("A" & RowNum) = False Then
                      XlSheet.Range("A" & RowNum) = "'" & "'" & elem.Handle 'Fill the columns with block data from modelspace
                   End If
                   XlSheet.Cells(RowNum, count + 2).value = Array1(count).TextString
                 
                 Next count
        
                 Header = True
              End If
            Next i 'Next Filter Check
           
           End If
         End If
       End With
     Next elem
     
 Xl.Sheets("Sheet1").Cells.EntireColumn.AutoFit



'************************************************************
'   'HERE is where the code to pull updated table from access goes…
'    Attribs(0).TextString = "THIS IS THE NEW NEW VALUE!"
'
'    ' Get the attributes again
'    Dim newAttrib As Variant
'    newAttrib = blkEntity.GetAttributes
'
'    ' Again, display the tags and values
'    strAttributes = ""
'    For i = LBound(newAttrib) To UBound(newAttrib)
'        strAttributes = strAttributes + "  Tag: " + _
'        newAttribs(i).TagString + vbCrLf + _
'        "   Value: " + newAttribs(i).TextString
'************************************************************


        'Xl.DisplayAlerts = False
        XlWorkbook.Save
        XlWorkbook.Close True '*** uncomment to keep open
        Xl.DisplayAlerts = True
        Xl.Quit
        
        Set XlSheet = Nothing
        Set XlWorkbook = Nothing
        Set Xl = Nothing
        GoTo Exit_Sub
        

Exit_XL_App:
        
        MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process"
        
        Xl.DisplayAlerts = False
        'XlBook.Save
        XlWorkbook.Close True '*** uncomment to keep open
        Xl.DisplayAlerts = True
        Xl.Quit
        
        Set XlSheet = Nothing
        Set XlWorkbook = Nothing
        Set Xl = Nothing
     
Exit_Sub:
     
End Sub