Thank you for the tips, I did use it, however I still need a little help looping through it. I tried but its not working...I need a little more direction

Thanks again

[code]
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


'************************************************* **********

' Code to import a field database and update the attribute table

'************************************************* **********
Dim ssnew As Object
Dim Entity As AcadEntity
Dim blkEntity As AcadBlockReference
Dim n As Variant 'Defaults to Variant

Dim Handle As String
Dim blockName As String
Dim tag As String
Dim Loops As String
Dim Address As String
Dim Label1 As String
Dim Label2 As String
Dim Device_Label As String
Dim Extended_Label As String
Dim Qty As String
Dim Model_Num As String
Dim Description As String
Dim Vendor As String
Dim CSFM_Num As String

Dim vAttrData
vAttrData = XlSheet.UsedRange

' Make Selection set of Blocks
' ----------------------------
Set activeDoc = ThisDrawing.Application.ActiveDocument
ThisDrawing.ActiveSpace = acModelSpace
With activeDoc
Set setColl = .SelectionSets
For Each setObj In .SelectionSets
If setObj.Name = "VBA" Then
.SelectionSets.Item("VBA").Delete
Exit For
End If
Next
Set ssnew = activeDoc.SelectionSets.Add("VBA")
End With
ssnew.Select acSelectionSetAll


' Get Attribute values
For Each Entity In ssnew

If Entity.ObjectName = "AcDbBlockReference" Then
Set blkEntity = Entity

If blkEntity.HasAttributes Then
Dim newAttribs As Variant

newAttribs = blkEntity.GetAttributes

For n = LBound(newAttribs) To UBound(newAttribs)

Select Case newAttribs(n).TagString

Case "HANDLE"
Handle = newAttribs(n).TextString
Case "BLOCKNAME"
blockName = newAttribs(n).TextString
Case "TAG"
tag = newAttribs(n).TextString
Case "LOOP"
Loops = newAttribs(n).TextString
Case "ADDRESS"
Address = newAttribs(n).TextString
Case "LABEL1"
Label1 = newAttribs(n).TextString
Case "LABEL2"
Label2 = newAttribs(n).TextString
Case "DEVICE_LABEL"
Device_Label = newAttribs(n).TextString
Case "EXTENDED_LABEL"
Extended_Label = newAttribs(n).TextString
Case "QTY"
Qty = newAttribs(n).TextString
Case "MODEL_NUM"
Model_Num = newAttribs(n).TextString
Case "DESCRIPTION"
Description = newAttribs(n).TextString
Case "VENDOR"
Vendor = newAttribs(n).TextString
Case "CSFM_NUM"
CSFM_Num = newAttribs(n).TextString

End Select
Next n
'Entity(n).Update 'This line does not work
End If
End If
Next Entity


'************************************************* ***********


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
[\code]