[转贴]：Excel Sort And Count Blocks

lsjjm

Description:

REQUIRED: Reference to the Excel Type Library
Connects to a running instance of Excel, CLEARS the contents of the active worksheet and then populates it with the names of all inserted block references. Once complete Excel is used to sort the sheet (removing duplicate entries) while counting the totals of each insert.
Snippet Code: - Excel Sort And Count Blocks

.:Double Click On Code To Copy:.

'Remember to add a reference to the
'Excel Object type Library!

Public Sub XLSortBlocksAndCount()
    Dim objExcel As Excel.Application
    Dim objSelSet As AcadSelectionSet
    Dim objBlkRef As AcadBlockReference
    Dim intRow As Integer
    Dim intBlkCnt As Integer
    Dim intType(0) As Integer
    Dim varData(0) As Variant
    Dim strValue As String
    On Error GoTo Err_Control
    'Excel MUST be running for this sample
    Set objExcel = GetObject(, "Excel.Application")
    'clears all cells - make sure there is nothing you
    'want in the active book
    objExcel.Cells.Select
    objExcel.Selection.ClearContents
    objExcel.Range("A1") = "Name"
    objExcel.Range("B1") = "Count"
    'Move to the first data row
    intRow = 2
    intType(0) = 0
    varData(0) = "INSERT"
    Set objSelSet = ThisDrawing.PickfirstSelectionSet
    objSelSet.Select acSelectionSetAll, filtertype:=intType, _
    filterdata:=varData
    For Each objBlkRef In objSelSet
        objExcel.Cells(intRow, 1).Value = objBlkRef.Name
        intRow = intRow + 1
    Next objBlkRef
    objExcel.ActiveSheet.Range("A1").Sort _
    key1:=objExcel.ActiveSheet.Columns("A"), _
    Header:=xlYes
    objExcel.Range("A1").Select
    objExcel.ActiveCell.Offset(1, 0).Select
    Do
    strValue = objExcel.ActiveCell.Value
    If objExcel.ActiveCell.Offset(1, 0).Value = strValue Then
        intBlkCnt = intBlkCnt + 1
        objExcel.Selection.Delete Shift:=xlUp
        objExcel.ActiveCell.Offset(-1, 0).Select
        Else
        'Add 1 for the first item the rest are compared against
        objExcel.ActiveSheet.Cells(objExcel.ActiveCell.Row, 2).Value = intBlkCnt + 1
        intBlkCnt = 0
    End If
    objExcel.ActiveCell.Offset(1, 0).Select
    Loop While strValue <> vbNullString
    Exit_Here:
    Exit Sub
    Err_Control:
    MsgBox Err.Description
    Resume Exit_Here
End Sub

xdcad9819

学习学习学习学习学习学习学习学习学习学习