Grab Attribute Data from Dwg Files in a Folder

Option Explicit
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
End Function
Public Sub PlotThisDirectory()
    Dim acadApp As Object
    Dim acadDoc As Object
    Dim BBarray() As Variant
    Dim BlkAtts As Variant
    Dim blknm As AcadBlockReference
    Dim CurrentFile As String
    Dim effName As String
    Dim FilterData() As Variant
    Dim FilterType() As Integer
    Dim i As Long
    Dim lastcolumn As Long
    Dim lastrow As Long
    Dim Nrows As Long
    Dim objInSelect As Variant
    Dim oSset As AcadSelectionSet
    Dim Path As String
    Dim rowBB As Long
    ReDim BBarray(1 To 2000, 1 To 16)
    ReDim FilterType(3)
    ReDim FilterData(3)
    On Error Resume Next
    'get the autodesk app
    Set acadApp = GetObject(, "AutoCAD.Application")
    acadApp.Visible = True
    If acadApp Is Nothing Then
        Set acadApp = CreateObject("AutoCAD.Application")
        acadApp.Visible = True
    End If
    If acadApp Is Nothing Then
        MsgBox "Sorry, it was impossible to get AutoCAD!", vbCritical, "AutoCAD Error"
        Exit Sub
    End If
    On Error GoTo 0
    acadApp.WindowState = acMax
    'let the user specify the folder path with the function GetFolder
    Path = GetFolder() & "\"
    CurrentFile = Dir(Path + "*.dwg", vbNormal)
    'loop through all the files
    rowBB = 1
    Do While CurrentFile <> ""
        acadApp.Documents.Open Path + CurrentFile, False
        Set acadDoc = acadApp.ActiveDocument
        acadDoc.ActiveSpace = acModelSpace
        'create a Filter List Conditions ,see  http://help.autodesk.com/view/ACD/2016/ENU/?guid=GUID-A1A6DB80-A730-45D1-B035-331F549E9667
        FilterType(0) = -4
        FilterType(1) = 67
        FilterType(2) = 0
        FilterType(3) = -4
        FilterData(0) = "<and"
        FilterData(1) = 0
        FilterData(2) = "INSERT"
        FilterData(3) = "and>"
        'create the selections set
        Set oSset = acadDoc.SelectionSets.Add("SS5")
        oSset.Select acSelectionSetAll, , , FilterType, FilterData
        rowBB = rowBB + 2
        BBarray(rowBB, 1) = CurrentFile
        rowBB = rowBB + 2
        On Error Resume Next
        For Each objInSelect In oSset
            Set blknm = objInSelect
            effName = objInSelect.Name
            Select Case effName
                Case "bom_title3"  'add as many cases as neeed that includes the block name
                    BlkAtts = objInSelect.GetAttributes
                    For i = 0 To UBound(BlkAtts)
                        BBarray(rowBB, i + 2) = BlkAtts(i).TextString
                    Next i
                    BBarray(rowBB, 16) = blknm.InsertionPoint(1)
                    rowBB = rowBB + 1
                Case "bom_title2"
                    BlkAtts = objInSelect.GetAttributes
                    For i = 0 To UBound(BlkAtts)
                        BBarray(rowBB, i + 2) = BlkAtts(i).TextString
                    Next i
                    BBarray(rowBB, 16) = blknm.InsertionPoint(1)
                    rowBB = rowBB + 1
            End Select
            effName = ""
        Next objInSelect
        On Error GoTo 0
        acadDoc.Close False
        CurrentFile = Dir
    Loop
    Nrows = UBound(BBarray, 1) - LBound(BBarray, 1)  'find are large the array is
    With Sheet1
        'clear the existing data
        On Error Resume Next
        lastcolumn = .Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        lastrow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        On Error GoTo 0
        If lastrow > 17 And lastcolumn > 0 Then
            .Range(.Cells(18, 1), .Cells(lastrow, lastcolumn)).Clear
        End If
        'place the array of data into the sheet
        .Range(.Cells(18, 1), .Cells(18 + Nrows, 16)) = BBarray
        .Columns("A:O").Columns.AutoFit
    End With
    Call sort_the_data
End Sub
Sub sort_the_data()
'sort the data according the y coordinate of the insertion point
'will only sort within each separate drawing
    Application.ScreenUpdating = False
    With Sheet1
        Dim truelastrow As Long
        Dim lastrow As Long
        Dim startrow As Long
        Dim loopcounter As Long
        truelastrow = .Cells(Rows.Count, "p").End(xlUp).Row
        startrow = 22
        loopcounter = 1
        Do Until lastrow > truelastrow
            lastrow = .Cells(startrow, "a").End(xlDown).Row - 3
            .Sort.SortFields.Clear
            .Sort.SortFields.Add2 Key:=.Cells(lastrow, "p"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            With .Sort
                .SetRange Range(Cells(startrow, "a"), Cells(lastrow, "p"))
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            startrow = lastrow + 5
        Loop
        truelastrow = .Cells(Rows.Count, "p").End(xlUp).Row
        Range(Cells(22, "p"), Cells(truelastrow, "p")).Clear
    End With
    Application.ScreenUpdating = True
End Sub