Подсчет блоков по атрибуту

Option Explicit
' request Reference to:
' Microsoft Excel XX.X Object Library
Const blkName As String = "MLR" '<-- change block name
Const attName As String = "PRESET" '<-- change attribute tag
Sub CountBlocksByAttribute()
    Dim oSset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim oBlkRef As AcadBlockReference
    Dim oFstRef As AcadBlockReference
    Dim oAtt As AcadAttributeReference
    Dim attArr() As AcadAttributeReference
    Dim fstArr As Variant
    Dim tmpStr As String
    Dim i As Long, j As Long
    Dim counter As Integer, m As Integer
    Dim ftype(1) As Integer
    Dim fdata(1) As Variant
    Dim dxfCode, dxfValue
    On Error GoTo Err_Control
    ftype(0) = 0: ftype(1) = 2
    fdata(0) = "INSERT": fdata(1) = blkName
    dxfCode = ftype: dxfValue = fdata
    With ThisDrawing.SelectionSets
        While .Count > 0
            .Item(0).Delete
        Wend
        Set oSset = .Add("$Blocks$")
    End With
    oSset.Select acSelectionSetAll, , , dxfCode, dxfValue
    Set oEnt = oSset.Item(0)
    Set oFstRef = oEnt
    fstArr = oFstRef.GetAttributes
    i = UBound(fstArr)
    ' headers (unused in this context)
    'ReDim hdr(i) As String
    '
    'For j = 0 To i
    'Set oAtt = fstArr(j)
    'If StrComp(oAtt.TagString, attName, vbTextCompare) = 0 Then
    'hdr(j) = oAtt.TagString
    'Else
    'hdr(0) = oAtt.TagString
    'End If
    'Next
    Dim uniqColl As New Collection
    Dim countColl As New Collection
    For Each oEnt In oSset
        Set oBlkRef = oEnt
        attArr = oBlkRef.GetAttributes
        On Error Resume Next
        For i = 0 To UBound(attArr)
            Set oAtt = attArr(i)
            If StrComp(oAtt.TagString, attName, vbTextCompare) = 0 Then
                uniqColl.Add oAtt.TextString, oAtt.TextString
            End If
        Next i
    Next oEnt
    If Err Then
        Err.Clear
    End If
    For i = 1 To uniqColl.Count
        tmpStr = uniqColl.Item(i)
        counter = 0
        For Each oEnt In oSset
            Set oBlkRef = oEnt
            attArr = oBlkRef.GetAttributes
            For j = 0 To UBound(attArr)
                Set oAtt = attArr(j)
                If StrComp(UCase(oAtt.TextString), UCase(tmpStr), 1) = 0 Then
                    counter = counter + 1
                    Exit For
                End If
            Next j
        Next oEnt
        ReDim tmp(UBound(fstArr) + 1) As String
        tmp(0) = CStr(counter): tmp(1) = tmpStr
        For j = 0 To UBound(fstArr)
            Set oAtt = fstArr(j)
            If StrComp(oAtt.TagString, "PRESET", 1) <> 0 Then
                tmp(j + 2) = oAtt.TextString
            End If
        Next
        countColl.Add tmp, tmpStr
    Next i
    DoEvents
    ''~~~~~~~~~ Excel part ~~~~~~~~~''
    Dim xlApp As Excel.Application
    Dim xlBooks As Excel.Workbooks
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Set xlApp = GetExcelOpen
    If Not xlApp Is Nothing Then
        xlApp.Visible = True
        Debug.Print "Success"
    Else
        Debug.Print "Failed"
        Exit Sub
    End If
    Set xlBooks = xlApp.Workbooks
    xlBooks.Add
    Set xlBook = xlApp.ActiveWorkbook
    Set xlSheet = xlBook.Sheets(1)
    xlSheet.Name = blkName
    xlSheet.Activate
    With xlSheet
        Dim itm As Variant
        For i = 1 To countColl.Count
            itm = countColl.Item(i)
            For j = 0 To UBound(itm)
                .Cells(i, j + 1) = itm(j)
            Next
        Next
        .Columns.HorizontalAlignment = xlHAlignLeft
        .Columns.AutoFit
    End With
    xlBook.SaveAs ThisDrawing.Path & "\" & blkName & ".xls"
    xlBook.Close
    xlApp.Application.Quit
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlBooks = Nothing
    Set xlApp = Nothing
    DoEvents
    MsgBox "Done"
Err_Control:
If Err.Number <> 0 Then
    MsgBox Err.Description
    End If
End Sub
'' written by Joe Sutphin
Public Function GetExcelOpen() As Excel.Application
    On Error Resume Next
    Set GetExcelOpen = GetObject(, "Excel.Application")
    If Err Then
        Err.Clear
        Set GetExcelOpen = CreateObject("Excel.Application")
        If Err Then
            MsgBox "Could not start Excel Application", vbExclamation
            Exit Function
        End If
    End If
End Function