Как перенести аттрибуты блока в Excel?

'Установи ссылку: Tools >> Referencies... >>
Microsoft Excel 9.0 Object Library

Public Sub AttributesOut()

Dim xlObj As Excel.Application

     Set xlObj = GetObject(, "Excel.Application")
     xlObj.Visible = True

Dim Cnt
Cnt = 2

Dim Ent As AcadEntity
Dim Blck As AcadBlockReference
Dim varAttributes As Variant
Dim I As Integer
Dim TagA
Dim TextA

For Each Ent In ThisDrawing.ModelSpace   '*****
     If Ent.ObjectName = "AcDbBlockReference" Then
        ' MsgBox Ent.Name
         Select Case Ent.Name
         
         Case "Ventsec"  '// Имя блока можно не указывать, т.е. убрать select case проверку. Тогда перебор будет по всем блокам.
                 xlObj.Worksheets(1).Range("H" & Cnt).Value = Ent.Handle
                 varAttributes = Ent.GetAttributes
                               
                 For I = LBound(varAttributes) To UBound(varAttributes)
                 TagA = varAttributes(I).TagString
                 TextA = varAttributes(I).TextString
                  xlObj.Worksheets(1).Range("A" & Cnt).Value = (Cnt - 1)
                 ' xlObj.Worksheets(2).Range("i" & Cnt).Value = Ent.Name
                     Select Case TagA ' Проверка имени атрибута
                     Case "NO" ' Укажи свои названия
                     xlObj.Worksheets(1).Range("B" & Cnt).Value = TextA
                     Case "Velo"
                     xlObj.Worksheets(1).Range("C" & Cnt).Value = TextA
                      Case "DROP"
                     xlObj.Worksheets(1).Range("D" & Cnt).Value = TextA
                       Case "LEN"
                     xlObj.Worksheets(1).Range("E" & Cnt).Value = TextA
                   
                     End Select
                     Next
                 Cnt = Cnt + 1
       
     End Select
End If
Next
End Sub

' Koд старый. Его можно ускорить если проверять не по всем entities , а только блоки. Но это работает.
Время будет - попробуй модернизировать:
     
     Dim objBlk As AcadBlock
     Dim objAllBlks As AcadBlocks
     Set objAllBlks = ThisDrawing.Blocks
     For Each objBlk In objAllBlks  '***** Дальше продолжи как указано выше, только не забудь объявить другие переменные.
............................

Good Luck