Dictionary, Collection, Instr, XLookup, or ???

[JenniferMurphy]

I am working on a macro that will process the columns in a table. The processing is controlled by several "helper" rows positioned above the table. Here's a simple example.

Weighted Ratings.xlsm
	B	C	D	E	F	G
4		Headers	Price	Range	Avail	Headroom
5		Types	Num	Num	Num	Num
6		Orders	LoHi	HiLo	LoHi	HiLo
7		Weights	1	2	1	3
8	Car	WtdRtg	Price	Range	Avail	Headroom
9	A	-3.23859	$34K	300 mi	0 mo	5 in
10	B	-1.91962	$54K	320 mi	3 mo	3 in
11	C	+2.37962	$63K	350 mi	9 mo	7 in
12	D	+2.77859	$76K	420 mi	0 mo	8 in
WtdRtg

This example has 4 helper rows (4:7):

• Row 4 (Headers) is a copy of the table headers so the macro can check that they are correctly aligned.
• Row 5 (Types) tells the macro the type of the data in this column. So far, I only have numeric data, but there will be others.
• Row 6 (Orders) tells the macro whether high values or low values are preferred.
• Row 7 (Weights) tells the macro what relative weight to assign to the values in this column.

The macro will do a validity check on each value in each helper row. For example, it will check that all of the Orders cells contain either "HiLo" or "LoHi". In the past, I would use Instr. I just learned about the Dictionary object and the Collection object. I am currently leaning toward the Dictionary object.

I would appreciate any thoughts on which might be better for this situation. These tables will be fairly small, so efficiency won't matter much, but I would like to learn how write efficient code on principle.

Thanks

 

[aaewalsh]

The Dictionary and Collection objects are both useful for storing and manipulating data in a VBA macro. The main difference between the two is that a Dictionary object uses keys and values to store data, while a Collection object stores its elements in a single, unordered collection.

A Dictionary object can be useful in this scenario because you can use the headers in Row 4 as the keys, and then use the corresponding values in Rows 5, 6, and 7 to store the type, order, and weight information for each column. This allows you to easily access and manipulate the data based on the specific column header.

Using the Dictionary object, you can check if all the value of the order column is either "HiLo" or "LoHi" by running a for loop for all the keys in dictionary, check the value corresponding to key 'Orders' and compare it with either 'HiLo' or 'LoHi' and proceed accordingly.

Using the Collection object is also possible but It will be less efficient as it does not have a key-value pair like a Dictionary. You will need to iterate over the Collection object to find the data for a specific column, making it more time-consuming to access and manipulate the data.

Try This:

' Declare and initialize a new Dictionary object
Dim columnData As Object
Set columnData = CreateObject("Scripting.Dictionary")

' Declare variables for the row and column indices
Dim row As Integer, col As Integer

' Loop through the columns in Row 4 (Headers)
For col = 1 To 7
    ' Get the header value
    Dim header As String
    header = Cells(4, col).Value

    ' Add the header as a key to the dictionary, and create new sub-dictionaries to store the type, order, and weight information
    columnData.Add header, CreateObject("Scripting.Dictionary")
    columnData(header).Add "Type", Cells(5, col).Value
    columnData(header).Add "Order", Cells(6, col).Value
    columnData(header).Add "Weight", Cells(7, col).Value
Next col

' Now you can easily access and manipulate the data for a specific column using the header as the key
For Each key in columnData
    'check for the Order key values
    If (columnData(key)("Order") <> "HiLo") and (columnData(key)("Order") <> "LoHi") Then
        MsgBox "Invalid order value for column " & key & ": " & columnData(key)("Order")
        Exit Sub
    End If
Next key

This macro creates a new Dictionary object called "columnData" and uses the headers in Row 4 as the keys. It then loops through the columns in Row 4, adds each header as a key to the Dictionary, and creates new sub-dictionaries to store the type, order, and weight information for that column. After the data has been stored in the dictionary, it loops over the dictionary keys and check if the order is 'HiLo' or 'LoHi' or not and if not then it will give an error message.

 

[offthelip]

I use a very similar optimising prgram and I just use simple variant array which are very fast, I can't see any partuclar advantage in using dictionaries or collectiosn because you need access each value only once to calculate the optimising value.
I think you also need to think about how you are going to scale the different columns, the price column is in thousands while the range in hundreds you give double the weight to the range but if you take the raw numbers price is 1000 times weightier. You could scale them by the average or by the maximium or the minimum, or by some target value where any value which is above it has the same value. So I think you need another "helper" row with "scale" in it
Here is my optimising code modified for your table, howver it doesn't take account of your hilo /lohi row becaus I don't know how you want that "scaled"

Sub optimiser()
typearr = Range(Cells(2, 1), Cells(2, 6))
Order = Range(Cells(2, 1), Cells(2, 6))
Weight = Range(Cells(4, 1), Cells(4, 6))

Lastrow = Cells(Rows.Count, "B").End(xlUp).Row


inarr = Range(Cells(1, 1), Cells(Lastrow, 20))
Range(Cells(1, 21), Cells(Lastrow, 21)) = ""
outarr = Range(Cells(1, 21), Cells(Lastrow, 21))
For i = 6 To Lastrow
  coSum = 0
 For j = 3 To 6
   If typearr(1, j) = "Num" Then
     ' weight the coord
      If IsNumeric(Weight(1, j)) Then
       wcoord = Weight(1, j) * inarr(i, j)
      Else
       wcoord = coord
      End If
     coSum = coSum + (wcoord * wcoord)
   End If
 Next j
 optim = Sqr(coSum)
 outarr(i, 1) = optim
 
Next i
 outarr(1, 1) = "optimiser"

Range(Cells(1, 21), Cells(Lastrow, 21)) = outarr


End Sub

Ps I put the result in column 21 to save overwriting column 2

 

[JenniferMurphy]

The Dictionary and Collection objects are both useful for storing and manipulating data in a VBA macro. The main difference between the two is that a Dictionary object uses keys and values to store data, while a Collection object stores its elements in a single, unordered collection.

. . .

Wow. Thanks for that detailed explanation and the sample code. Impressive. I am especially delighted to know about sub-dictionaries. I don't recall any of the various websites I visited even mentioning that.

I am just wondering if this is overkill. As mentioned by offthelip, I will only access each individual value twice. Once when initializing the Dictionary and once when using them to check the helper rows (that's what I am calling rows 4:7) for valid values. After that, I will use the actual values in those rows, which I have read into memory, to process the data in the table.

After I posted my question, I did the following test implementation. It works, but so did my previous implementation using InStr. And I don't really have a "value" to associate with each "key", so I used a dummy value (1). Here's the code that declares and populates the valid values:

' I am testing Dictionaries for looking up valid keywords (instead of InStr)
' These are the "master" values against which the sheet values will be compared.
' Make them all upper case.
Dim DictTypes As New Dictionary   'The property types
DictTypes.Add "NUM", 1              'Just one so far
Dim DictOrders As New Dictionary  'The property orders
DictOrders.Add "HILO", 1            'Higher values are better
DictOrders.Add "LOHI", 1            'Lower values are better

And this is the code that does the validity checking.

' Validity check the helper rows
For iCol = 1 To NumCols - 2
  ' Do the headers match the table headers?
  If UCase(arrHlprHdrs(1, iCol)) <> UCase(arrTableHdrs(1, iCol + 2)) Then
    Call ErrMsg("Header helper #" & iCol & " (" & arrHlprHdrs(1, iCol) & ")" _
          & " <> Table header", MyName)
    Exit Sub: End If
  ' Are the types in the list
  If Not DictTypes.Exists(UCase(arrHlprTyps(1, iCol))) Then
    Call ErrMsg("Invalid type helper #" & iCol & " (" & arrHlprTyps(1, iCol) & ")", MyName)
    Exit Sub: End If
  ' Are the orders in the list
  If Not DictOrders.Exists(UCase(arrHlprOrds(1, iCol))) Then
    Call ErrMsg("Invalid order helper #" & iCol & " (" & arrHlprOrds(1, iCol) & ")", MyName)
    Exit Sub: End If
  ' Are the weights all numbers?
  If Not IsNumeric(arrHlprWts(1, iCol)) Or IsEmpty(arrHlprWts(1, iCol)) Then
    Call ErrMsg("Weight helper #" & iCol & " (" & arrHlprWts(1, iCol) & ") is not numeric", MyName)
    Exit Sub: End If
Next iCol

 

[JenniferMurphy]

I use a very similar optimising prgram and I just use simple variant array which are very fast, I can't see any partuclar advantage in using dictionaries or collectiosn because you need access each value only once to calculate the optimising value.

That's true. Their only purpose is to check that the sheet values are valid. After that, I use the sheet values, which I have read into memory.

I think you also need to think about how you are going to scale the different columns, the price column is in thousands while the range in hundreds you give double the weight to the range but if you take the raw numbers price is 1000 times weightier. You could scale them by the average or by the maximium or the minimum, or by some target value where any value which is above it has the same value. So I think you need another "helper" row with "scale" in it.

I convert the data in each column to Z Scores z = (x - mean) / stddev. This converts every column to a mean of zero and a stddev of 1. And as for the HiLo row, I just change the sign z = -z.

Here is my optimising code modified for your table, howver it doesn't take account of your hilo /lohi row becaus I don't know how you want that "scaled"

Sub optimiser()
typearr = Range(Cells(2, 1), Cells(2, 6))
Order = Range(Cells(2, 1), Cells(2, 6))
Weight = Range(Cells(4, 1), Cells(4, 6))

Lastrow = Cells(Rows.Count, "B").End(xlUp).Row


inarr = Range(Cells(1, 1), Cells(Lastrow, 20))
Range(Cells(1, 21), Cells(Lastrow, 21)) = ""
outarr = Range(Cells(1, 21), Cells(Lastrow, 21))
For i = 6 To Lastrow
  coSum = 0
 For j = 3 To 6
   If typearr(1, j) = "Num" Then
     ' weight the coord
      If IsNumeric(Weight(1, j)) Then
       wcoord = Weight(1, j) * inarr(i, j)
      Else
       wcoord = coord
      End If
     coSum = coSum + (wcoord * wcoord)
   End If
 Next j
 optim = Sqr(coSum)
 outarr(i, 1) = optim
 
Next i
 outarr(1, 1) = "optimiser"

Range(Cells(1, 21), Cells(Lastrow, 21)) = outarr


End Sub

Ps I put the result in column 21 to save overwriting column 2

I didn't provide enough information for you (or anyone) to be able to write sample code. I wasn't expecting such thorough and detailed answers.

You code looks like a reasonable solution once it's adapted to my exact situation.

The primary reason I asked about Dictionaries and Collections is because of problems I have had in the past with InStr. Since it's a string search and not a word search, I have had problems with it matching part of a word. I had to make sure that none of the words were contained in any of the others. I was looking a simple word search.

Let me play with your suggestion. I'll get back later.

Thanks for the help.

 

[JenniferMurphy]

I think you also need to think about how you are going to scale the different columns, the price column is in thousands while the range in hundreds you give double the weight to the range but if you take the raw numbers price is 1000 times weightier. You could scale them by the average or by the maximium or the minimum, or by some target value where any value which is above it has the same value. So I think you need another "helper" row with "scale" in it

Here's an example of some raw data points with wildly different "scales" and how the Z Scores puts them all on the same scale.

Weighted Ratings.xlsm
	I	J	K	L	M
8		Base	x10.00	x123.46	x0.03
9	Scores	34.0000	340.0000	4,197.5040	1.0268
10		54.0000	540.0000	6,666.6240	1.6308
11		63.0000	630.0000	7,777.7280	1.9026
12		76.0000	760.0000	9,382.6560	2.2952
13	Mean	56.7500	567.5000	7,006.1280	1.7139
14	Std Dev	17.6517	176.5172	2,179.2111	0.5331
15	Z Scores	-1.2888	-1.2888	-1.2888	-1.2888
16		-0.1558	-0.1558	-0.1558	-0.1558
17		+0.3541	+0.3541	+0.3541	+0.3541
18		+1.0905	+1.0905	+1.0905	+1.0905
WtdRtg

Cell Formulas
Range	Formula
K9:M12	K9	=$J9*K$8
J13:M13	J13	=AVERAGE(J9:J12)
J14:M14	J14	=STDEV.S(J9:J12)
J15:M18	J15	=(J9-J$13)/J$14

 

[JenniferMurphy]

I have studied both suggestions. I don't believe I fully understand either one, but that may because I provided insufficient information about my project for either one to really understand what my objective is. As a result, I think the solutions may be for a slightly different problem than the one I am trying to solve. Regardless, I did learn a lot from each one one. Thank you both.

I was relectant to post the entire macro code because of its size. I am going to do that now. If this is too large, feel free to delete it.

First, here is the table that is it working on. Rows 4:7 are the "helper" rows. Rows 8:12 are the table, whose name is in C2. Rows 14:21 do manually the calculations that are done in the macro. This is to check that the3 macro is working properly. If so, C9:C12 in the table (the only output fro the macro) will match C17:C20.

Weighted Ratings.xlsm
	B	C	D	E	F	G
2		TblMain	Table name
3
4		Headers	Price	Range	Avail	Headroom
5		Types	Num	Num	Num	Num
6		Orders	LoHi	LoHi	LoHi	HiLo
7		Weights	1	2	1	3
8	Car	WtdRtg	Price	Range	Avail	Headroom
9	A	+2.79005	$34K	300 mi	0 mo	5 in
10	B	-2.51763	$54K	320 mi	3 mo	3 in
11	C	-0.17229	$63K	350 mi	9 mo	7 in
12	D	-0.10013	$76K	420 mi	0 mo	8 in
13
14		Mean	$56.75K	347.5 mi	3.00 mo	5.75 in
15		Std Dev	17.6517	52.5198	4.2426	2.2174
16	Car	WtdRtg	Price	Range	Avail	Headroom
17	A	+2.79005	+1.28883	+0.90442	+0.70711	-0.33824
18	B	-2.51763	+0.15579	+0.52361	-0.00000	-1.24022
19	C	-0.17229	-0.35407	-0.04760	-1.41421	+0.56373
20	D	-0.10013	-1.09055	-1.38043	+0.70711	+1.01472
21		Z Sum	=0.00000	=0.00000	=0.00000	=0.00000
WtdRtg

Cell Formulas
Range	Formula
D4,D16	D4	=TblMain[[#Headers],[Price]]
E4,E16	E4	=TblMain[[#Headers],[Range]]
F4,F16	F4	=TblMain[[#Headers],[Avail]]
G4,G16	G4	=TblMain[[#Headers],[Headroom]]
D14	D14	=AVERAGE(TblMain[Price])
E14	E14	=AVERAGE(TblMain[Range])
F14	F14	=AVERAGE(TblMain[Avail])
G14	G14	=AVERAGE(TblMain[Headroom])
D15	D15	=STDEV.S(TblMain[Price])
E15	E15	=STDEV.S(TblMain[Range])
F15	F15	=STDEV.S(TblMain[Avail])
G15	G15	=STDEV.S(TblMain[Headroom])
D17:G20	D17	=ZScore(D9,D$14,D$15,D$6)
D21:G21	D21	=SUM(D17:D20)
B16	B16	=TblMain[[#Headers],[Car]]
C16	C16	=TblMain[[#Headers],[WtdRtg]]
C17:C20	C17	=SUMPRODUCT(D17:G17,D$7:G$7)

And here is the code. It uses 2 subfunctions, ErrMsg and ZScore. That code is below.

Sub WtdRtg()

Const MyName As String = "WtdRtg"   'The name of this macro for error messages

' Some constants
Const WtdRtgCol As Long = 2 'The weighted rating column
Const MinRows As Long = 1   'Table must have at least 1 row
Const MinCols As Long = 3   'Table must have at least 3 columns (name, wtdrtg, 1 attribute)

Const HlprHdrName As String = "Headers" 'The label for the Headers row
Const HlprTypName As String = "Types"   'The label for the Types row
Const HlprOrdName As String = "Orders"  'The label for the Orders row
Const HlprWtName As String = "Weights"  'The label for the Weights row

Const ValidTypes As String = "|NUM|"            'List of valid types
Const ValidOrds As String = "|HILO|LOHI|"       'List of valid orders

' Named ranges
Const rnTableName As String = "TableName"     'The name of the table
Const rnHlprHdrs As String = "HelperHeaders"  'The Headers helper row label
Const rnHlprTyps As String = "HelperTypes"    'The Types helper row label
Const rnHlprOrds As String = "HelperOrders"   'The Orders helper row label
Const rnHlprWts As String = "HelperWeights"   'The Weights helper row label

' Worker variables
Dim iCol As Long    'Loop index
Dim iRow As Long    'Loop index
Dim sTmp As String  'Temporary string variable

' Get the name of the table
Dim rnTable As String                     'The name of the table
  rnTable = Range(rnTableName).Value2     '.Load the table name

' Define a ListObject variable. It will replace ActiveSheet.ListObject in the rest of the code
Dim loTable As ListObject
  Set loTable = Range(rnTable).ListObject

' Load the headers into one array and the body into another
Dim arrTableHdrs As Variant      'The table header row
  arrTableHdrs = loTable.HeaderRowRange.Value2
Dim arrTableData As Variant      'The table data (body)
  arrTableData = loTable.DataBodyRange.Value2

' Do some validity checking
Dim NumRows As Long               'Get the number of rows
  NumRows = UBound(arrTableData, 1)
  If NumRows < MinRows Then
    Call ErrMsg("Table has less than " & MinRows & " rows", MyName)
    Exit Sub: End If
Dim NumCols As Long               'Get the number of columns
  NumCols = UBound(arrTableData, 2)
  If NumCols < MinCols Then
    Call ErrMsg("Table has less than " & MinCols & " columns", MyName)
    Exit Sub: End If

' Check the helper row labels
sTmp = Range(rnHlprHdrs).Value2   'Check the Header helper label
If sTmp <> HlprHdrName Then
  Call ErrMsg("Invalid Header helper row label (" & sTmp & ")" _
               & vbCrLf & "Expected (" & HlprHdrName & ")", MyName)
  Exit Sub: End If
sTmp = Range(rnHlprTyps).Value2   'Check the Type helper label
If sTmp <> HlprTypName Then
  Call ErrMsg("Invalid Type helper row label (" & sTmp & ")" _
               & vbCrLf & "Expected (" & HlprTypName & ")", MyName)
  Exit Sub: End If
sTmp = Range(rnHlprOrds).Value2   'Check the Order helper label
If sTmp <> HlprOrdName Then
  Call ErrMsg("Invalid Order helper row label (" & sTmp & ")" _
               & vbCrLf & "Expected (" & HlprOrdName & ")", MyName)
  Exit Sub: End If
sTmp = Range(rnHlprWts).Value2    'Check the Weight helper label
If sTmp <> HlprWtName Then
  Call ErrMsg("Invalid Weight helper row label (" & sTmp & ")" _
               & vbCrLf & "Expected (" & HlprWtName & ")", MyName)
  Exit Sub: End If

' Load the helper rows
Dim arrHlprHdrs As Variant          'Load the helper headers
  sTmp = Range(rnHlprHdrs).Offset(0, 1).Address & ":" _
     & Range(rnHlprHdrs).Offset(0, NumCols - 2).Address
  arrHlprHdrs = Range(sTmp).Value2
Dim arrHlprTyps As Variant          'Load the helper types
  sTmp = Range(rnHlprTyps).Offset(0, 1).Address & ":" _
     & Range(rnHlprTyps).Offset(0, NumCols - 2).Address
  arrHlprTyps = Range(sTmp).Value2
Dim arrHlprOrds As Variant          'Load the helper orders
  sTmp = Range(rnHlprOrds).Offset(0, 1).Address & ":" _
     & Range(rnHlprOrds).Offset(0, NumCols - 2).Address
  arrHlprOrds = Range(sTmp).Value2
Dim arrHlprWts As Variant          'Load the helper weights
  sTmp = Range(rnHlprWts).Offset(0, 1).Address & ":" _
     & Range(rnHlprWts).Offset(0, NumCols - 2).Address
  arrHlprWts = Range(sTmp).Value2
 
' Validity check the individual helper rows
For iCol = 1 To NumCols - 2
  ' Do the headers match the table headers?
  If UCase(arrHlprHdrs(1, iCol)) <> UCase(arrTableHdrs(1, iCol + 2)) Then
    Call ErrMsg("Header helper #" & iCol & " (" & arrHlprHdrs(1, iCol) & ")" _
          & " <> Table header", MyName)
    Exit Sub: End If
  ' Are the types in the list
  If 0 = InStr(1, ValidTypes, (UCase(arrHlprTyps(1, iCol)))) _
        Or IsEmpty(arrHlprTyps(1, iCol)) Then
    Call ErrMsg("Invalid Type helper #" & iCol & " (" & arrHlprTyps(1, iCol) & ")", MyName)
    Exit Sub: End If
  ' Are the orders in the list
  If 0 = InStr(1, ValidOrds, (UCase(arrHlprOrds(1, iCol)))) _
         Or IsEmpty(arrHlprOrds(1, iCol)) Then
    Call ErrMsg("Invalid Order helper #" & iCol & " (" & arrHlprOrds(1, iCol) & ")", MyName)
    Exit Sub: End If
  ' Are the weights all numbers?
  If Not IsNumeric(arrHlprWts(1, iCol)) Or IsEmpty(arrHlprWts(1, iCol)) Then
    Call ErrMsg("Weight helper #" & iCol & " (" & arrHlprWts(1, iCol) & ") is not numeric", MyName)
    Exit Sub: End If
Next iCol

' Calculate the means and standard deviations for the property columns
Dim Mean As Double        'The mean
Dim StdDev As Double      'The std dev
Dim Z As Double           'Next Z Score
For iRow = 1 To NumRows   'Zero the WtdRtgs
  arrTableData(iRow, WtdRtgCol) = 0
Next iRow

' Now, finally, do the work
For iCol = MinCols To NumCols   'Loop through the property columns
  With Application.WorksheetFunction
    Mean = .Average(.Index(arrTableData, 0, iCol))    'Calculate the mean
    StdDev = .StDev_S(.Index(arrTableData, 0, iCol))  '.and the std ev
  End With
  For iRow = 1 To NumRows           'Calculate the Z Score for each row in this column
    Z = ZScore(arrTableData(iRow, iCol), Mean, StdDev, arrHlprOrds(1, iCol - 2))
    arrTableData(iRow, WtdRtgCol) = arrTableData(iRow, WtdRtgCol) _
        + (Z * arrHlprWts(1, iCol - 2))   'Add the weighted Z Score
  Next iRow
Next iCol

' Write out just weighted ratings column (2) of the array
loTable.ListColumns(arrTableHdrs(1, WtdRtgCol)).DataBodyRange.Resize(UBound(arrTableData, 1)) _
       = Application.Index(arrTableData, 0, WtdRtgCol)

End Sub

Here are ErrMsg and ZScore.

Sub ErrMsg(msg As String, fnname As String)
MsgBox msg, vbOKOnly, fnname
End Sub


Function ZScore(pValue As Variant, pMean As Variant, pStdDev As Variant _
              , pOrder As Variant) As Double

' If the value is not a number, return zero,
' which is the same as setting it to the average of the other values.
'If Not WorksheetFunction.IsNumber(pValue) Then  'If not a number,
'  ZScore = 0: Exit Function: End If               'Return zero

' If std dev is zero, return 0; else calculate Z Score
If pStdDev = 0 Then                   'If std dev = 0,
  ZScore = 0                            'Return 0
Else                                  'Else
  ZScore = (pValue - pMean) / pStdDev   'Calculate the ZScore
  If UCase(pOrder) = "LOHI" Then      'If range order is reversed,
    ZScore = -ZScore: End If            'Reverse the ZScores
End If

End Function