Finding Comparables Setup
Filling Classes and Finding Specific Instances
Filtering and Sorting Classes
In this final installment, I look at the code to write a class module to a range. That is represented by the last two lines of this controlling procedure:
Dim clsCompanies As CCompanies
Dim clsWisky As CCompanies
Dim vaOutput As Variant
Dim clsFocus As CCompany
‘Fill all companies
Set clsCompanies = New CCompanies
clsCompanies.Fill Sheet1.Range(“A2:D201”)
‘identify the one I care about
Set clsFocus = clsCompanies.FindByName(“Monarch”)
‘get only those companies in the same state
Set clsWisky = clsCompanies.FilterByState(clsFocus.State)
‘sort them by sales
clsWisky.SortBySales
‘get an array of the 3 below and 3 above
vaOutput = clsWisky.WriteComparables(clsFocus, 3)
‘write it to a range
Sheet1.Range(“G1”).Resize(UBound(vaOutput, 1), UBound(vaOutput, 2)).Value = vaOutput
End Sub
A quick and efficient way to write data to a worksheet, typically a slow process, is to assign an array to the Value property of a Range. This is done in two steps in the above procedure. The first step is to pull certain data out of the class into the Variant Array vaOutput. The second step is to assign that Variant Array to the Value property of a range.
To get the data into an array, I wrote the WriteComparables property. It returns a Variant (a data type that can be anything), which in this case will be an array. The second argument, lRange, is how I tell the property how many companies before and after the focus company I want to return, in this case 3.
Dim aReturn() As Variant
Dim lFocus As Long
Dim i As Long
Dim clsCurr As CCompany
Dim lCount As Long
Dim lStart As Long, lEnd As Long
lFocus = clsFocus.Index
If lFocus > lRange Then
lStart = -lRange
Else
lStart = -lFocus + 1
End If
If lFocus < Me.Count – (lRange – 1) Then
lEnd = lRange
Else
lEnd = Me.Count – lFocus
End If
ReDim aReturn(1 To (lEnd – lStart) + 2, 1 To 4)
aReturn(1, 1) = “Company”
aReturn(1, 2) = “City”
aReturn(1, 3) = “State”
aReturn(1, 4) = “Sales”
lCount = 1
For i = lStart To lEnd
Set clsCurr = Me.Company(lFocus + i)
lCount = lCount + 1
If clsCurr.CompanyID = clsFocus.CompanyID Then
aReturn(lCount, 1) = “*” & clsCurr.CompanyName
Else
aReturn(lCount, 1) = clsCurr.CompanyName
End If
aReturn(lCount, 2) = clsCurr.City
aReturn(lCount, 3) = clsCurr.State
aReturn(lCount, 4) = clsCurr.Sales
Next i
WriteComparables = aReturn
End Property
The basics of this procedure is to loop through a certain number of companies and fill the array with certain properties. That seems easy enough. But it gets slightly more complicated if there are not enough companies before or after my focus company. For instance, if I have eight companies in my class and my focus company is number seven on the list, then I will only have one company that comes after the focus company.
To account for that, I set lStart and lEnd to determine how far I should go. The first step is to find out where my focus company is. The Index property returns my focus company’s position in the order.
Dim i As Long
For i = 1 To Me.Parent.Count
If Me.Parent.Company(i).CompanyID = Me.CompanyID Then
Index = i
Exit For
End If
Next i
End Property
This simply loops through every company in the Parent (a CCompanies class) until it finds the focus company. Then it returns i, which is the position in the list. The next several lines determine lStart and lEnd. The easy case is when my focus company is in the middle with plenty of companies before and after it. In that case, I loop from -lRange to lRange (in this example, -3 to 3). If lFocus is too close to the start of the list, I set lStart equal to -lFocus + 1 (the first company in the class). If lFocus is too close to the end of the list, I set lEnd to Me.Count-lFocus (the last company in the class). What I’m actually getting in those two situations is where the first and last companies are compared to where lFocus is.
In this example, there are plenty of companies before Monarch but only two after. I will be looping from -3 to 2 (as offset from lFocus).
Next I establish the dimensions of aReturn. The first “row” of the array will be a header, so I create one more row than I need to hold the companies. In this case, -3 to 2 is six companies (0 is my focus company), so my “row” dimension is 1 to (2 – (-3)) + 2 or 1 to 7.
The next few lines put my header information in to the first element of aReturn and set the lCount (the counter I use to determine what row I’m on) to 1 so as to skip the first row where the header is.
Finally, we get to the loop. Remember we’re looping from -3 to 2. I set clsCurr to the company that’s at lFocus + i. For the first pass through the loop, that will get (6 + (-3)) or the third company in the list. The If block in the loop appends an asterisk in front of the company name if it’s the focus company. The rest of the For loop puts certain data (City, State, and Sales) into the proper “column” dimensions of the array.
The last line assigns the array to the property name so that’s it’s returned to the calling procedure.
Back in the controlling procedure, I want to start my output in cell G1. I resize that array for the number of dimensions in the array. If the array has 6×4 dimensions, then my range is resized to six rows and four columns. Assigning vaOutput to the Value property writes the whole array to the Range at once.
The result shows the three companies whose sales are less than Monarch’s and the two (because there are only two) companies whose sales are greater.
To recap, here are the steps we took to get this list: First, we filled a collection class with all the companies. Next, we found our focus company with a property of the collection class that returns a company given a name or partial name. Then we created a new collection class with only those companies with the same state. We sorted that class on the Sales property. Next, we created an array with the companies a certain number away (both before and after) our focus company. Finally, we assigned that array to the Value property of a Range to write it to the worksheet.
You can download SortFilterClass.zip
Writing an array to a range in one ‘hit’ is such a common tasks that most Excel developers have a utility function lying around…
‘ Write an array to an Excel range in a single ‘hit’ to the sheet
‘ InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)
‘ The target range is resized automatically to the dimensions of the array, with
‘ the top left cell used as the start point.
‘ This subroutine saves repetitive coding for a common VBA and Excel task.
Dim rngOutput As Excel.Range
Dim iRowCount As Long
Dim iColCount As Long
Dim iRow As Integer
Dim arrTemp As Variant
Dim iDimensions As Integer
Dim PriorSetting_EnableEvents As Boolean
PriorSetting_EnableEvents = Application.EnableEvents
Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
rngTarget.ClearContents
End If
iDimensions = ArrayDimensions(InputArray)
If iDimensions < 1 Then
rngTarget.Value = CStr(InputArray)
ElseIf iDimensions = 1 Then
iRowCount = UBound(InputArray) – LBound(InputArray)
iColCount = 1
‘ It’s a vector. Yes, I asked for a 2-Dimensional array. But I’m feeling generous.
‘ By convention, a vector is presented in Excel as an arry of 1 to n rows and 1 column.
ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
arrTemp(iRow, 1) = InputArray(iRow)
Next
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
rngOutput.Value2 = arrTemp
Set rngTarget = rngOutput
End With
Erase arrTemp
ElseIf iDimensions = 2 Then
iRowCount = UBound(InputArray, 1) – LBound(InputArray, 1)
iColCount = UBound(InputArray, 2) – LBound(InputArray, 2)
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
rngOutput.Value = InputArray
Set rngTarget = rngOutput
End With
End If
ExitSub:
Application.EnableEvents = PriorSetting_EnableEvents
End Sub
The difficult part is ascertaining the dimensions of the array – is it the expected 2-dimensional array, a vector, or have we received a scalar (a conventional string or numeric variant)?
You can try to do this by querying:
Ubound(myVariant, 2) Ubound(myVariant) InStr(Typename(myVariant), “(“)
…But you need to use On Error Resume Next and a lot of coding. I prefer to use the ArrayDimensions() function published by RB Smissaert:
‘—————————————————————–
‘ will return:
‘ -1 if not an array
‘ 0 if an un-dimmed array
‘ 1 or more indicating the number of dimensions of a dimmed array
‘—————————————————————–
‘ Originally published by R. B. Smissaert.
‘ Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax
Dim ptr As Long
Dim vType As Integer
Const VT_BYREF = &H4000&
‘get the real VarType of the argument
‘this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory vType, arr, 2
‘exit if not an array
If (vType And vbArray) = 0 Then
ArrayDimensions = -1
Exit Function
End If
‘get the address of the SAFEARRAY descriptor
‘this is stored in the second half of the
‘Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
‘see whether the routine was passed a Variant
‘that contains an array, rather than directly an array
‘in the former case ptr already points to the SA structure.
‘Thanks to Monte Hansen for this fix
If (vType And VT_BYREF) Then
‘ ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
‘get the address of the SAFEARRAY structure
‘this is stored in the descriptor
‘get the first word of the SAFEARRAY structure
‘which holds the number of dimensions
‘…but first check that saAddr is non-zero, otherwise
‘this routine bombs when the array is uninitialized
If ptr Then
CopyMemory ArrayDimensions, ByVal ptr, 2
End If
End Function
This requires an API function, CopyMemory, declared as shown:
(Destination As Any, _
Source As Any, _
ByVal Length As Long)