VBA: How to loop through multiple variant arrays of the same length and turn them into Objects - excel

I currently have 3 separate variants that are all arrays consisting of 13 rows and 1 column. One variant represents names, another represents changes and the last represents occurrences. Please see my starter code below:
Sub watchList()
Dim names As Variant
names = Sheets("Watch Calculations").Range("B4:B16")
Dim changes As Variant
changes = Sheets("Watch Calculations").Range("G4:G16")
Dim occurances As Variant
occurrences = Sheets("Watch Calculations").Range("G22:G34")
End Sub
I also have a class called counterParty with the following fields:
Public Name As String
Public changeStatus As String
Public negativeOccurences As Integer
How can I loop through all 3 variants at the same time and input the values into an object of the counterParty class based on the row number of each variant. Please see psuedo code below:
Dim i As Integer
Dim MyArray(1 To 13) As Integer
For i = 1 To UBound(MyArray)
'psuedo code stars here
create new object of class counterParty
set object.Name = names(i,1)
set object.changeStatus = changes(i,1)
set object.negativeOccurences= occurrences.get(i,1)
add object to array of counterParty objects
Next i

Try this out
First the class module:
Private pName As String
Private pchangeStatus As String
Private pnegativeOccurrences As Long
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(lName As String)
pName = lName
End Property
Public Property Get changeStatus() As String
changeStatus = pchangeStatus
End Property
Public Property Let changeStatus(lchangeStatus As String)
pchangeStatus = lchangeStatus
End Property
Public Property Get negativeOccurrences() As Long
negativeOccurrences = pnegativeOccurrences
End Property
Public Property Let negativeOccurrences(lnegativeOccurrences As Long)
pnegativeOccurrences = lnegativeOccurrences
End Property
Then the module:
Dim names As Variant
names = Sheets("Watch Calculations").Range("B4:B16")
Dim changes As Variant
changes = Sheets("Watch Calculations").Range("G4:G16")
Dim occurrences As Variant
occurrences = Sheets("Watch Calculations").Range("G22:G34")
Dim i As Long
Dim clsarr(1 To 13) As Object 'You can use lbound and ubound on names() to get dynamic values
Dim mycls As Class1
For i = 1 To UBound(names)
Set mycls = New Class1 'Overwrite current object
'assign values to the class properties
mycls.Name = names(i, 1)
mycls.changeStatus = changes(i, 1)
mycls.negativeOccurrences = occurrences(i, 1)
Set clsarr(i) = mycls
Next i

Related

Trouble with late-bound functions

Greetings I have the following code:
Private Sub makeNewReports()
Dim wkSheet As Worksheet
Set wkSheet = ActiveWorkbook.Worksheets("Grades")
Dim i As Long
Dim myMap As Dictionary
Set myMap = New Dictionary
For i = 4 To 6 'wkSheet.Range("a1").End(xlToRight).Column - 1
Dim myVals As dateValueItem
myVals.total_value = wkSheet.Cells(2, i)
myVals.items = wkSheet.Cells(1, i)
myVals.student_value = wkSheet.Cells(4, i)
myMap.Add wkSheet.Cells(3, i), myVals
Next i
End Sub
and the following code for dateValueItem
Option Explicit
Public Type dateValueItem
total_value As Long
items As String
student_value As Long
End Type
when I run the above code I get the problem
'Compile Error: Only user-defined types defined in public object modules can be coerced to or from a variant or passed to late bound functions'
I'm trying to map together 3 different values to a specific date; the dates are held in row three. Row 2 and 4 has numerical values, and row 1 has string values. The hope is to be able to organize all of these together so I can eventually connect descriptions and values to dates.
This might be the quickest way. Create a class and name it dateValueItem
Option Explicit
Public total_value As Long
Public items As String
Public student_value As Long
And change your code to
Option Explicit
Private Sub makeNewReports()
Dim wkSheet As Worksheet
Set wkSheet = ActiveWorkbook.Worksheets("Grades")
Dim i As Long
Dim myMap As Dictionary
Set myMap = New Dictionary
Dim myVals As dateValueItem
For i = 4 To 6 'wkSheet.Range("a1").End(xlToRight).Column - 1
Set myVals = New dateValueItem
myVals.total_value = wkSheet.Cells(2, i)
myVals.items = wkSheet.Cells(1, i)
myVals.student_value = wkSheet.Cells(4, i)
myMap.Add wkSheet.Cells(3, i), myVals
Next i
End Sub

How to speed up the comparision of 2 collections in VBA?

I have written a macro that gets a collection of collection and than takes two of the collections and gives me the similarity.
Now if I compare the two collections with a simple for loop it will take hours to compare all 854 collection that are contained in pCol.
Here is my code:
Function CompareCollections(ByVal pCol As Collection) As Collection
Dim outer As Long
Dim inner As Long
'collections that will be compared to each other
Dim inCol As Collection
Dim outCol As Collection
'collection used for return values
Dim retCol As Collection
'result of single comparison
Dim res As CompResult
'comparison variables
Dim iIdx As Long
Dim oIdx As Long
Dim same As Long
Set retCol = New Collection
For outer = 1 To pCol.Count - 1
Set outCol = pCol(outer)
For inner = outer + 1 To pCol.Count
Set inCol = pCol(inner)
Set res = New CompResult
res.LeftTable = outCol(1) 'index 1 contains a header
res.RightTable = inCol(1)
'compare the two collections <== PART I WANT TO SPEED UP
same = 0
For oIdx = 2 To outCol.Count 'starting with 2 to ignore the header
For iIdx = 2 To inCol.Count
If inCol(iIdx) = outCol(oIdx) Then same = same + 1
Next iIdx
DoEvents
Next oIdx
res.Result1 = same / (outCol.Count - 1)
res.Result2 = same / (inCol.Count - 1)
retCol.Add res
Set res = Nothing
Set inCol = Nothing
DoEvents
Next inner
Set outCol = Nothing
DoEvents
Next outer
Set CompareCollections = retCol
End Function
I really hope you guys can help me.
EDIT:
The CompResult class is a simple structure, because I could not add a custom type to the collection:
Private mLeftTable As String
Private mRightTable As String
Private mResult1 As Double
Private mResult2 As Double
Public Property Get LeftTable() As String
LeftTable = mLeftTable
End Property
Public Property Let LeftTable(value As String)
mLeftTable = value
End Property
Public Property Get RightTable() As String
RightTable = mRightTable
End Property
Public Property Let RightTable(value As String)
mRightTable = value
End Property
Public Property Get Result1() As Double
Result = mResult1
End Property
Public Property Let Result1(value As Double)
mResult1 = value
End Property
Public Property Get Result2() As Double
Result = mResult2
End Property
Public Property Let Result2(value As Double)
mResult2 = value
End Property
A first tip: try to precalculate outCol.Count, inCol.Count and pCol.Count in order to avoid unnecessary calculations.
Second tip: if in your object CompResult the res.Result1 and res.Result2 are integers, use "\" instead of "/".
Third tip: try to use integers instead of long values wherever you can.
Fourth tip: try to replace for loops by a "for each" loops when looping for every column. It seems a little faster.
A last tip might be transform collections (ranges) in arrays and iterate through them, as it seems faster than iterate through ranges.

Excel VBA function take 2 different data type and loop through collection of class module

I have following sub working but get #VALUE! error after change sub into function.
Working sub as follow
Sub Get_Tier2(ByVal myCategory As String, ByVal myMSRP As Double)
Dim ProductTiers As Collection
Dim pt As ProductTier
Dim result As String
Dim CIDTierCount As Integer
CIDTierCount = ThisWorkbook.Worksheets("CIDTier").Range("A:A").CurrentRegion.Rows.Count
Set ProductTiers = New Collection
For i = 2 To CIDTierCount
Set pt = New ProductTier
pt.Category = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("B")
pt.Tier = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("C")
pt.MSRP_Low = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("D")
pt.MSRP_High = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("E")
ProductTiers.Add pt
Next
For Each pt In ProductTiers
If StrComp(pt.Category, myCategory) = 0 And pt.MSRP_Low < myMSRP And myMSRP < pt.MSRP_High Then
result = pt.Tier()
MsgBox result
Exit Sub
Else
'do nothing
End If
Next
End Sub
When I change the sub to function and try to use in excel, it will return me #VALUE! in excel
Function Get_Tier(ByVal myCategory As String, ByVal myMSRP As Double) As String
Dim ProductTiers As Collection
Dim pt As ProductTier
Dim result As String
Dim CIDTierCount As Integer
CIDTierCount = ThisWorkbook.Worksheets("CIDTier").Range("A:A").CurrentRegion.Rows.Count
Set ProductTiers = New Collection
For i = 2 To CIDTierCount
Set pt = New ProductTier
pt.Category = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("B")
pt.Tier = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("C")
pt.MSRP_Low = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("D")
pt.MSRP_High = ThisWorkbook.Worksheets("CIDTier").Rows(i).Columns("E")
ProductTiers.Add pt
Next
For Each pt In ProductTiers
If StrComp(pt.Category, myCategory) = 0 And pt.MSRP_Low < myMSRP And myMSRP < pt.MSRP_High Then
Get_Tier = pt.Tier()
Exit Function
Else
Get_Tier = "no match"
End If
Next
End Function
Class Module ProductTier are as follow
Private pCategory As String
Private pTier As String
Private pMSRP_Low As Double
Private pMSRP_High As Double
Public Property Get Category() As String
Category = pCategory
End Property
Public Property Let Category(Value As String)
pCategory = Value
End Property
Public Property Get Tier() As String
Tier = pTier
End Property
Public Property Let Tier(Value As String)
pTier = Value
End Property
Public Property Get MSRP_Low() As String
MSRP_Low = pMSRP_Low
End Property
Public Property Let MSRP_Low(Value As String)
pMSRP_Low = Value
End Property
Public Property Get MSRP_High() As String
MSRP_High = pMSRP_High
End Property
Public Property Let MSRP_High(Value As String)
pMSRP_High = Value
End Property
And the data on CIDTier tab
Column B: ProductA
Column C: Tier 1
Column D: 0
Column E: 300
The Culprit
CIDTierCount = ThisWorkbook.Worksheets("CIDTier").Range("A:A").CurrentRegion.Rows.Count
If you throw a debug marker on that line and print what
ThisWorkbook.Worksheets("CIDTier").Range("A:A").CurrentRegion.Rows.Count
returns, you get 1048576. This will overflow the Integer you are trying to place it in.
Possible Solution
From what you are doing, it looks like you want a count of rows, you can try changing the code to the following:
CIDTierCount = Worksheets("CIDTier").UsedRange.Rows.Count
Why this works
In Excel, each worksheet has a range that is defined as the UsedRange. This range goes from A1 to the farthest right column that is formatted or contains data and the lowest row that is formatted or contains data.

Best way to lookup a list of character strings against dictionary to output English words

I've got a list of about 20,000 strictly alpha/text character strings outputted as a CSV file to Excel, but it's quite a mess.
What I want to do is query a separate, reference file of English dictionary words so that I can essentially create a lookup and return the dictionary word, minus a load of the text noise that is either prepended or appended to the string. Example below.
xyzbuildingcontractor = Building Contractor
upholsteryabcdef = Upholstery
lmnoengineer = Engineer
As a relative n00b programmer I just want to gauge opinion as to the best way to do this and whether Excel is the best platform to use.
Any guidance would be very gratefully recieved, thanks in advance.
Jim
Ok, this is a very rough draft which you might have to tweak, but the general idea is this:
A Trie is used to build a dictionary of words
A clsTrieIterator class allows tracking multiple words at a time within the Trie
The string to be tested is parsed one character at a time, each one starting a new clsTrieIterator
All the existing active clsTrieIterators consume each next character, and if the resulting combination of characters is not possible given the dictionary, it stops being tracked
Here is a short example of the use:
Public Sub Main()
Dim wf As clsWordFinder
Set wf = New clsWordFinder
wf.Add "Building"
wf.Add "Contractor"
wf.Add "Upholstery"
wf.Add "Engineer"
Debug.Print wf.getWordsFromString("xyzbuildingcontractor")
Debug.Print wf.getWordsFromString("upholsteryabcdef")
Debug.Print wf.getWordsFromString("lmnoengineer")
End Sub
Which outputs the following to the immediate window in VBA:
Building Contractor
Upholstery
Engineer
...and below are the classes.
clsTrieNode is each individual node of the tree. It represents a single letter and it may have up to 26 children, assuming they form valid words in the dictionary. If the combination of characters, node by node down the tree from the root to this point forms a word, the Trie will set "isWord".
Option Compare Database
Option Explicit
Public KeyChar As String
Public isWord As Boolean
Private m_Children(0 To 25) As clsTrieNode
Public Property Get Child(strChar As String) As clsTrieNode
'better be ONE char
Set Child = m_Children(charToIndex(strChar))
End Property
Public Property Set Child(strChar As String, oNode As clsTrieNode)
Set m_Children(charToIndex(strChar)) = oNode
End Property
Private Function charToIndex(strChar As String) As Long
charToIndex = Asc(strChar) - 97 'asc("a")
End Function
clsTrie is the public facing interface to interact with the tree of nodes that forms the trie. It contains an Add method to put words into the dictionary and an isWord method which allows testing a string against the trie dictionary to see if it is a valid word. Remove is a method that is nice to have, but probably not necessary for your problem, so I haven't implemented it.
Option Compare Database
Option Explicit
Private m_Head As clsTrieNode
Private Sub Class_Initialize()
Set m_Head = New clsTrieNode
End Sub
Public Sub Add(strKey As String)
Dim currNode As clsTrieNode
Dim tempNode As clsTrieNode
Set currNode = m_Head
Dim strLCaseKey As String
strLCaseKey = LCase(strKey)
Dim i As Long
For i = 1 To Len(strLCaseKey)
If Not currNode.Child(Mid(strLCaseKey, i, 1)) Is Nothing Then
Set currNode = currNode.Child(Mid(strLCaseKey, i, 1))
Else
Exit For
End If
Next
For i = i To Len(strLCaseKey)
Set tempNode = New clsTrieNode
tempNode.KeyChar = Mid(strLCaseKey, i, 1)
Set currNode.Child(Mid(strLCaseKey, i, 1)) = tempNode
Set currNode = tempNode
Next
currNode.isWord = True
End Sub
Public Sub Remove(strKey As String)
'Might be nice to have
End Sub
Public Function isWord(strKey As String)
Dim currNode As clsTrieNode
Set currNode = m_Head
Dim strLCaseKey As String
strLCaseKey = LCase(strKey)
Dim i As Long
For i = 1 To Len(strLCaseKey)
If Not currNode.Child(Mid(strLCaseKey, i, 1)) Is Nothing Then
Set currNode = currNode.Child(Mid(strLCaseKey, i, 1))
Else
isWord = False
Exit Function
End If
Next
If currNode.isWord Then
isWord = True
Else
isWord = False
End If
End Function
Public Function getIterator() As clsTrieIterator
Dim oIterator As clsTrieIterator
Set oIterator = New clsTrieIterator
oIterator.Init m_Head
Set getIterator = oIterator
End Function
clsTrieIterator is a special class returned by clsTrie which allows parsing of a string to be done character by character with consumeChar instead of all at once as with clsTrie.isWord. This allows some freedom in parsing the string without backtracking or reading the same character more than once and it allows finding words when you are not sure how long they will be.
Option Compare Database
Option Explicit
Private m_currNode As clsTrieNode
Private m_currString As String
Public Property Get getCurrentString() As String
getCurrentString = m_currString
End Property
Public Sub Init(oNode As clsTrieNode)
Set m_currNode = oNode
End Sub
Public Function consumeChar(strChar As String) As Boolean
Dim strLCaseChar As String
strLCaseChar = LCase(strChar)
If Not m_currNode.Child(strLCaseChar) Is Nothing Then
consumeChar = True
Set m_currNode = m_currNode.Child(strLCaseChar)
m_currString = m_currString & strChar
Else
consumeChar = False
Set m_currNode = Nothing
End If
End Function
Public Function isWord() As Boolean
isWord = m_currNode.isWord
End Function
clsWordFinder puts everything together in a simple api tailored to your specific problem. It might be worth adding some logic to handle different behavior, like "greedy" matching vs "lazy" matching and overlapping vs nonoverlapping word parsing.
Option Compare Database
Option Explicit
Private m_Trie As clsTrie
Private Sub Class_Initialize()
Set m_Trie = New clsTrie
End Sub
Public Sub Add(strWord As String)
m_Trie.Add strWord
End Sub
Public Function getWordsFromString(strString As String) As String
Dim colIterators As Collection
Set colIterators = New Collection
Dim colMatches As Collection
Set colMatches = New Collection
Dim oIterator As clsTrieIterator
Dim strMatch As String
Dim i As Long
Dim iter
For i = 1 To Len(strString)
Set oIterator = m_Trie.getIterator
colIterators.Add oIterator, CStr(ObjPtr(oIterator))
For Each iter In colIterators
If Not iter.consumeChar(Mid(strString, i, 1)) Then
colIterators.Remove CStr(ObjPtr(iter))
ElseIf iter.isWord() Then
strMatch = iter.getCurrentString
Mid(strMatch, 1, 1) = UCase(Mid(strMatch, 1, 1))
colMatches.Add strMatch
colIterators.Remove CStr(ObjPtr(iter))
End If
Next
Next
getWordsFromString = JoinCollection(colMatches)
End Function
Public Function getWordsCollectionFromString(strString As String) As Collection
Dim colIterators As Collection
Set colIterators = New Collection
Dim colMatches As Collection
Set colMatches = New Collection
Dim oIterator As clsTrieIterator
Dim strMatch As String
Dim i As Long
Dim iter
For i = 1 To Len(strString)
Set oIterator = m_Trie.getIterator
colIterators.Add oIterator, CStr(ObjPtr(oIterator))
For Each iter In colIterators
If Not iter.consumeChar(Mid(strString, i, 1)) Then
colIterators.Remove CStr(ObjPtr(iter))
ElseIf iter.isWord() Then
strMatch = iter.getCurrentString
Mid(strMatch, 1, 1) = UCase(Mid(strMatch, 1, 1))
colMatches.Add strMatch
colIterators.Remove CStr(ObjPtr(iter))
End If
Next
Next
Set getWordsCollectionFromString = colMatches
End Function
Private Function JoinCollection(colStrings As Collection, Optional strDelimiter = " ") As String
Dim strOut As String
Dim i As Long
If colStrings.Count > 0 Then
strOut = colStrings.Item(1)
For i = 2 To colStrings.Count
strOut = strOut & strDelimiter & colStrings.Item(i)
Next
JoinCollection = strOut
End If
End Function

Excel 2010 vba array as a class member error

I am working on a project and have run into something that I don't understand. When assigning an array to a class member, the Let and Get names cannot be the same. If they are, I get the error:
Definitions of property procedures for the same property are inconsistent, or property procedure has an optional parameter, a ParamArray, or an invalid Set final parameter
Can anyone tell me if I'm just doing something wrong, or if this is just how it is. The code below generates the above message.
Test Code:
Sub loadServer()
Dim testServer As AvayaServer
Dim i As Long
Dim arr() As Variant
arr = Array("1", "2", "3", "4", "5")
Set testServer = New AvayaServer
testServer.Name = "This Sucks"
testServer.Skill = arr
MsgBox testServer.Skills(4)
MsgBox testServer.Name
End Sub
Class Code:
Private pName As String
Private pSkills() As String
Public Property Get Skills() As Variant
Skills = pSkills()
End Property
Public Property Let Skills(values() As Variant)
ReDim pSkills(UBound(values))
Dim i As Long
For i = LBound(values) To UBound(values)
pSkills(i) = values(i)
Next
End Property
Change values() As Variant to values As Variant:
Class Code:
Private pName As String
Private pSkills() As String
Public Property Get Skills() As Variant
Skills = pSkills()
End Property
Public Property Let Skills(values As Variant) 'Fixed here
ReDim pSkills(UBound(values))
Dim i As Long
For i = LBound(values) To UBound(values)
pSkills(i) = values(i)
Next
End Property
Explanation:
values As Variant will be of type Variant, which you later use to store an array.
values() As Variant is an array of type Variant, to which an Array cannot be assigned; an Array can only be assigned to the former.

Resources