as to me you did a very cool work!
what follows are suggestions of no effect for small elaborations (i.e. with a few items to work with). you may take them into account for general purpose. or not at all!
' cool "cxhair" routines with some "RICVBA" minor modifications
Option Explicit
'use "Public" instead of "Private" if you want this Sub to be called via "tools/Macro/Macro" menu commands
Public Sub Inc2()
Dim SSet1 As AcadSelectionSet, SSet2 As AcadSelectionSet ' the lesser the codelines the better the code readability. moreover I'd group variables together when of the same type and/or for the same purposes
Dim ArrY() As AcadText
Dim ArrN() As Integer
Dim i As Integer, j As Integer ' see what above
Dim fType(1) As Integer
Dim fData(1) As Variant
Set SSet1 = Csset("SSet1_1x")
fType(0) = 0: fData(0) = "TEXT"
fType(1) = 1: fData(1) = "*"
SSet1.SelectOnScreen fType, fData ' you could enclose this statament in a do-while loop until the user makes a valid selection (for instance with a select items number > 0)
' or you could place here a control to catch a selection with no items and exit sub (and may be throwing a warning message, too)
ReDim ArrY(SSet1.Count - 1)
ReDim ArrN(SSet1.Count - 1)
fData(1) = ""
For i = 0 To UBound(ArrY)
Set ArrY(i) = SSet1.Item(i)
fData(1) = fData(1) & SSet1.Item(i).TextString & ","
Next
SSet1.Delete 'unless you need it for further elaborations
OrderY ArrY()
'-----------------------
Set SSet2 = Csset("SSet2_2x")
SSet2.SelectOnScreen fType, fData ' same pieces of advice as above for SSet1
For i = 0 To SSet2.Count - 1
With SSet2.Item(i)
For j = 0 To UBound(ArrY)
If StrComp(.TextString, ArrY(j).TextString, vbTextCompare) = 0 Then
ArrN(j) = ArrN(j) + 1
Exit For
End If
Next
End With
Next
SSet2.Delete 'unless you need it for further elaborations
'-----------------------
For i = 0 To UBound(ArrY)
ThisDrawing.Utility.Prompt vbCrLf & "No.[ " & ArrY(i).TextString & " ] " & " the Quantity is --------" & ArrN(i)
Next
ThisDrawing.Utility.Prompt vbCrLf
End Sub
Private Function Csset(Str As String) As AcadSelectionSet
' sometimes errors can be useful! managing them is a useful technique that avoids you a lot of work
On Error Resume Next
ThisDrawing.SelectionSets.Item(Str).Delete ' delete a SelectionSet with the given name (Str), if already there
On Error GoTo 0
Set Csset = ThisDrawing.SelectionSets.Add(Str) ' now you can safely add a SelectionSet with the given name
End Function
' you don't use "OrderY" as a true Function (there's no "OrderY =..." or "set OrderY =..." statements inside)
' so let's call it by its name: a Sub!
' You can write faster procedures if you use specific data types (AcadText, in this case) instead of Variant
' moreover, using Variant would be a false generalization in this case (if that was your aim) since not all objects have "InsertionPoint" property as AcadText has.
' if you look at "AutoCAD ActiveX and VBA Reference" guide you'll see that it's common to Attribute, AttributeReference, BlockRef, ExternalReference, MInsertBlock, MText, Shape, Table, Text, and Tolerance Symbol objects only
Private Sub OrderY(ByRef Arr() As AcadText) '
Dim i As Integer
Dim j As Integer
Dim Temp As AcadText
For i = 0 To UBound(Arr) - 1 ' the iteration for i = Ubound(arr) is not useful since every item is already in its right position. furthermore the following j loop wouldn't start since UBound(Arr) - (i + 1) would result in a negative number
For j = 0 To UBound(Arr) - (i + 1)
If Arr(j).InsertionPoint(1) < Arr(j + 1).InsertionPoint(1) Then
Set Temp = Arr(j)
Set Arr(j) = Arr(j + 1)
Set Arr(j + 1) = Temp
End If
Next
Next
End Sub
