vb6 equivalent to list<someclass> - list

I want to know if exist a equivalent of (.net)
list<somefixedclass>
in vb6
I know that exist collection in vb6 but it uses object (variant) instead of a specific object.
thanks.

There is no direct equivalent in VB 6 to the generic List<T> found in VB.NET. However, there is such a thing as a Collection in VB 6, which provides similar functionality. The primary difference is that a VB 6 Collection is not strongly-typed, which means that all objects are stored as Variants in the collection. In some cases, this can be beneficial, because it allows you to store many different types of data in the same collection, and in fact, VB uses this object internally. It's easy enough to use a Collection and up-cast objects as they are retrieved from the class, but there's little you can do. It's not possible to implement strongly-typed collections in the VB runtime.
That being said, there is a workaround you can implement. Similarly to how collections were implemented in early versions of VB.NET before generics were introduced, you can wrap the Collection in a class, where the only access to the internal Collection is through methods that you expose from this class. This design pattern is commonly referred to as a "custom collection".
This does have the benefit of automatically handling casting, and alleviates the consumers of your code from having to remember to mind implementation details like this. It takes care of the (all too likely) possibility that you'll be looping through a collection at run-time that is only supposed to contain one type of object, but accidentally had a second, incompatible type of object added that causes your code to throw an exception. Of course, the disadvantage is that you have to re-implement most of the functionality already provided by the Collection object yourself, in the form of public methods on your custom collection.
Here's an example of how you might go about that:
Public Class CustomerCollection
''#Internal collection, exposed by this class
Private m_Customers As Collection
Private Sub Class_Initialize()
''#Set up the internal collection
Set m_Customers = New Collection
End Sub
Public Sub Add(ByVal cust as Customer, Optional ByVal key as String)
''#Add the Customer object to the internal collection
If IsMissing(key) Then
m_Customers.Add cust
Else
m_Customers.Add cust, key
End If
End Sub
Public Property Get Count() As Integer
''#Return the number of objects in the internal collection
Count = m_Customers.Count
End Property
Public Sub Remove(ByVal index As Variant)
''#Remove the specified object from the internal collection,
''# either by its index or its key
m_Customers.Remove index
End Sub
Public Function Item(ByVal index As Variant) as Customer
''#Return the specified object from the internal collection,
''# either by its index or its key
Set Item = m_Customers.Item(index)
End Function
Public Sub Clear()
''#Removes all objects from the internal collection
Set m_Customers = New Collection
End Sub
End Class
Note that in order to set the custom collection's Item property as the collection's default method (like the built-in Collection object), you need to follow these steps in the VB 6 IDE:
From the "Tools" menu, click "Procedure Attributes"
Select the name of your custom class from the "Name" combo box.
When the dialog appears, click the "Advanced" button.
Select the "(Default)" item in the "Procedure ID" combo box.
Click "OK"
If you'd also like to allow enumeration of your custom class using the For Each syntax (also like the built-in Collection object), you can add a NewEnum function to your custom class:
Public Property Get NewEnum() As IUnknown
''#Provides support for enumeration using For Each
Set NewEnum = m_Customers.[_NewEnum]
End Property
Once you've done that, you need to instruct VB to use this property:
As before, open the "Procedure Attributes" dialog from the "Tools" menu
Select the name of your custom class from the "Name" combo box.
When the dialog appears, click the "Advanced" button.
Type the number "-4" in the "Procedure ID" combo box.
Click "OK"

Here is our implementation of ArrayList. You can use it as a base (not through inheritance obviously but through composition as expressed in CodyGray's answer) for a strongly typed class, but if you don't need type safety it is much better than the Collection class.
Option Explicit
Private mavInternalArray() As Variant
Private mlArraySize As Long
Private mlCount As Long
Private mlGrowSize As Long
Private mfZeroIndex As Boolean
'---------------------------------------------------------------------------------------
' Procedure Clear
'---------------------------------------------------------------------------------------
Public Sub Clear()
Dim index As Long
For index = 0 To mlCount - 1
If IsObject(mavInternalArray(index)) Then
Set mavInternalArray(index) = Nothing
End If
Next index
mlCount = 0
End Sub
'---------------------------------------------------------------------------------------
' Procedure Swap
'---------------------------------------------------------------------------------------
Public Sub Swap(Index1 As Long, index2 As Long)
Dim vTmp As Variant
If IsObject(mavInternalArray(index2)) Then
Set vTmp = mavInternalArray(index2)
Else
vTmp = mavInternalArray(index2)
End If
If IsObject(mavInternalArray(Index1)) Then
Set mavInternalArray(index2) = mavInternalArray(Index1)
Else
mavInternalArray(index2) = mavInternalArray(Index1)
End If
If IsObject(vTmp) Then
Set mavInternalArray(Index1) = vTmp
Else
mavInternalArray(Index1) = vTmp
End If
End Sub
Public Property Get ZeroIndex() As Boolean
ZeroIndex = mfZeroIndex
End Property
Public Property Let ZeroIndex(fZeroIndex As Boolean)
mfZeroIndex = fZeroIndex
End Property
Public Property Get GrowSize() As Long
GrowSize = mlGrowSize
End Property
Public Property Let GrowSize(lNewSize As Long)
Debug.Assert lNewSize > 0
mlGrowSize = lNewSize
End Property
Private Sub Class_Initialize()
mlGrowSize = 50
mlArraySize = mlGrowSize
mfZeroIndex = True
mlCount = 0
ReDim mavInternalArray(0 To mlGrowSize - 1)
End Sub
'---------------------------------------------------------------------------------------
' Procedure Remove
'---------------------------------------------------------------------------------------
Public Sub Remove(index As Long)
Dim index2 As Long
For index2 = index To mlCount - 2
If IsObject(mavInternalArray(index2 + 1)) Then
Set mavInternalArray(index2) = mavInternalArray(index2 + 1)
Else
mavInternalArray(index2) = mavInternalArray(index2 + 1)
End If
Next index2
If mlCount <= 0 Then
Exit Sub
End If
mlCount = mlCount - 1
If IsObject(mavInternalArray(mlCount)) Then
Set mavInternalArray(mlCount) = Nothing
Else
mavInternalArray(mlCount) = False
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure Items
'---------------------------------------------------------------------------------------
Public Function Items(index As Long) As Variant
If Not mfZeroIndex Then
index = index - 1
End If
If index < mlCount And index >= 0 Then
If IsObject(mavInternalArray(index)) Then
Set Items = mavInternalArray(index)
Else
Items = mavInternalArray(index)
End If
End If
End Function
Public Sub SetItem(index As Long, Item As Variant)
If Not mfZeroIndex Then
index = index - 1
End If
If IsObject(Item) Then
Set mavInternalArray(index) = Item
Else
mavInternalArray(index) = Item
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure Add
'---------------------------------------------------------------------------------------
Public Function Add(vItem As Variant) As Long
mlCount = mlCount + 1
If mlCount > mlArraySize Then
mlArraySize = mlArraySize + mlGrowSize
ReDim Preserve mavInternalArray(0 To mlArraySize - 1)
End If
If IsObject(vItem) Then
Set mavInternalArray(mlCount - 1) = vItem
Else
mavInternalArray(mlCount - 1) = vItem
End If
Add = mlCount - 1
End Function
'---------------------------------------------------------------------------------------
' Procedure ItemArray
'---------------------------------------------------------------------------------------
Public Function ItemArray() As Variant
Dim vReturnArray As Variant
vReturnArray = mavInternalArray
ReDim Preserve vReturnArray(0 To mlCount - 1)
ItemArray = vReturnArray
End Function
Public Function Count() As Long
Count = mlCount
End Function
'---------------------------------------------------------------------------------------
' Procedure Insert
'---------------------------------------------------------------------------------------
Public Function Insert(index As Long, vItem As Variant) As Long
Dim index2 As Long
'Make sure array is large enough for a new item
mlCount = mlCount + 1
If mlCount > mlArraySize Then
mlArraySize = mlArraySize + mlGrowSize
ReDim Preserve mavInternalArray(0 To mlArraySize - 1)
End If
'Bump all the items with a higher index up one spot
If index >= mlCount - 1 Then
If IsObject(vItem) Then
Set mavInternalArray(mlCount - 1) = vItem
Else
mavInternalArray(mlCount - 1) = vItem
End If
Else
For index2 = mlCount - 1 To index + 1 Step -1
If IsObject(vItem) Then
Set mavInternalArray(index2) = mavInternalArray(index2 - 1)
Else
mavInternalArray(index2) = mavInternalArray(index2 - 1)
End If
Next index2
If IsObject(vItem) Then
Set mavInternalArray(index) = vItem
Else
mavInternalArray(index) = vItem
End If
End If
Insert = mlCount - 1
End Function
Public Sub Clone(ByRef cDestinationDynamicArray As clsDynamicArray)
Dim index As Long
If cDestinationDynamicArray Is Nothing Then
Set cDestinationDynamicArray = New clsDynamicArray
End If
cDestinationDynamicArray.Clear
For index = 0 To mlCount - 1
Call cDestinationDynamicArray.Add(mavInternalArray(index))
Next index
End Sub
Public Property Get NewEnum() As IUnknown
''#Provides support for enumeration using For Each
Set NewEnum = m_Customers.[_NewEnum]
End Property

EDIT: if Cody Gray's solution is too oversized for your needs, you might try instead the "poor man's list" solution, as follows:
Dim l() as somefixedclass
Redim l(0)
'...
'increase size dynamically:
Redim Preserve l(ubound(l)+1)
'...
Of course, a List<somefixedclass> (in C#) or a List(Of somefixedclass) in VB.NET is much more "user-friendly" because it has methods like Find, Remove, AddRange and some other helpful things. The old VB6 construct deals very badly with the "empty list" case. Not to forget, List<..> increasement has much better performance for big lists (size>1000).

VB6 is an ancient language. It doesn't contain template-like types as there are in modern languages (C++, C#, Java). So you will have to store your objects as Variants in the collection and then cast them back to your object type later.

Dictionary is the best way to contain any object.

Related

Excel - Identify unique value patterns and return output in descending order across columns, optimized for 500,000+ rows

This is the third and final remaining problem to a massive data cleaning task I have been working on for over a year. Thank you Stack Overflow community for helping figure out:
Problem 1- Index multiple columns and Match distinct values....
Problem 2- Count unique values that match ID, optimized for 100,000+ cases.
I'm not 100% sure if the following is achievable in excel, but I'll do my best to describe the data cleaning and organization challenge I'm faced with.
I have a series of data markers/attributes that are in a random order across 24 columns, spanning 500,000+ rows. Image 1 below is an example of what the data looks like in raw form, presented across 12 columns and spanning 22 rows for illustrative simplicity. Columns A through L contain the raw data and Columns M through X represent the desired output.
SUMMARY OF THE TASK: What needs to be accomplished is a series of matching functions that search through all indexed columns (in this case columns A through L) to identify unique values (e.g. 1), search for the value in range (in this case A2:L21 range), identify the adjacent values to the unique value (for value 1, adjacent values are 2 and 13-XR), then output them in a descending sequence from most frequently occurring value to least frequently occurring in each row that contains any of the values in question (in this case, 1 occurs 5 times and is placed in M2 through M6; 2 occurs 3 times and is placed in N2 through N6; and 13-XR occurs 2 times and is placed in O2 through O6).
To clarify, below is a step by step description using colours to illustrate the pattern matching in the raw data (columns A through L) and how these patterns should then presented in the output (columns M through X). I've sectioned off each of the following images into the six patterns that are in the raw data.
The above image is the first pattern that would be identified by the VBA solution. It would identify "1" as a unique value and search through the A:L range for number of instances of "1" (highlighted in blue), then identify all the values that can be found adjacent in the same row: "2" in rows 3, 5, and 6 (highlighted in green); and "13-XR" in rows 4 and 5 (highlighted in pink). This would then need to be done for "2", identifying the adjacent values ("1" and "13-XR"), and then for "13-XR", identifying ("1" and "2" as adjacent values). The output would return the unique values with the most frequently occurring in Column M ("1" occurs 5 times), then the second most occurring in Column N ("2" occurs 3 times), and the third most occurring in Column O ("13-XR" occurs 2 times).
The above is little more complex. The VBA would identify "3" as a unique value, search through the A:L range for other instances of "3" and identify all the values that are adjacent to it (in this case, "4", "7", and "9"). It would then do the same for "4", identifying all adjacent values (only "3"); then for "7", identifying adjacent values ("9", "3", and "12"); then for "9" identifying ("7", and "3"); and finally, for "12" identifying adjacent values (only "7"). Then for each row where any of these values are present, the output would return a "3" in column M (occurring three times) and a "7" in column N (also occurring three times); if counts are equal, they could be presented in ascending fashion A to Z or smallest to largest... or just random, the ordering of equal counts is arbitrary for my purposes. "9" would be returned in column O as it occurs two times, then "4" in column P and "12" in column Q, as they both occur once but 12 is greater than 4.
The above image represents what is likely to be a common occurrence, where there is only one unique value. Here, "5" is not identified in any other columns in the range. It is thus returned as "5" in column M for each row where a "5" is present.
This will be another of the more common occurrences, where one value may be present in one row and two values present in another row. In this instance "6" is only identified once in the range and "8" is the only adjacent value found. When "8" is searched for it only returns one instance of an adjacent value "6". Here, "8" occurs twice and "6" only once, thus resulting in "8" imputed in column M and "6" imputed in column N wherever an "8" or a "6" are present in the row.
Here "10", "111", "112", "543", "433", "444", and "42-FG" are identified as unique values associated with one another in the A:L range. All values except "10" occur twice, which are returned in columns M through S in descending order.
This final pattern is identified in the same manner as above, just with more unique values (n=10).
FINAL NOTES: I have no idea how to accomplish this within excel, but I'm hoping someone else has the knowledge to move this problem forward. Here are some additional notes about the data that might help towards a resolution:
The first column will always be sorted in ascending order. I can do additional custom sorts if it simplifies things.
Out of the ~500,000 rows, 15% only have one attribute value (one value in column A), 30% have two attribute values (1 value in col A & 1 value in col B), 13% have three attribute values (1 value in col A, B, & C).
I have presented small numbers in this example. The actual raw data values in each cell will be closer to 20 characters in length.
A solution that does everything except present the patterns in descending order would be absolutely cool. The sorting would be great but I can live without it if it causes too much trouble.
If anything in this description needs further clarification, or if I can provide additional information, please let me know and I'll adjust as needed.
Thanks in advance to anyone who can help solve this final challenge of mine.
ADDENDUM:
There was a memory error happening with the full data set. #ambie figured out the source of the error was adjacent chains (results) numbering in the 1000s (trying to return results across 1000s of columns). Seems the problem is not with the solution or the data, just hitting a limitation within excel. A possible solution to this is (see image below) to add two new columns (ATT_COUNT as column M; ATT_ALL as column Z). ATT_COUNT in Column M would return the total number of unique values that would ordinarily be returned across columns. Only up to the top 12 most frequently occurring values would be returned in columns N through Y (ATT_1_CL through ATT_12_CL). To get around the instances where ATT_COUNT is > 12 (& upwards of 1000+), we can return all the unique values in space delimited format in ATT_ALL (column Z). For example, in the image below, rows 17, 18, 19, and 21, have 17 unique values in the chain. Only the first 12 most frequently occurring values are presented in columns N through Y. All 17 values are presented in space delimited format in column Z.
Here is a link to this mini example test data.
Here is a link to a mid sized sample of test data of ~50k rows.
Here is a link to the full sized sample test data of ~500k rows.
We don't normally provide a 'code for you service' but I know in previous questions you have provided some sample code that you've tried, and I can see how you wouldn't know where to start with this.
For your future coding work, the trick is to break the problem down into individual tasks. For your problem, these would be:
Identify all the unique values and acquire a list of all the adjacent values - fairly simple.
Create a list of 'chains' which link one adjacent value to the next - this is more awkward because, although the list appears sorted, the adjacent values are not, so a value relatively low down in the list might be adjacent to a higher value that is already part of a chain (the 3 in your sample is an example of this). So the simplest thing would be to assign the chains only after all the unique values have been read.
Map of each unique value to its appropriate 'chain' - I've done this by creating an index for the chains and assigning the relevant one to the unique value.
Collection objects are ideal for you because they deal with the issue of duplicates, allow you to populate lists of an unknown size and make value mapping easy with their Key property. To make the coding easy to read, I've created a class containing some fields. So first of all, insert a Class Module and call it cItem. The code behind this class would be:
Option Explicit
Public Element As String
Public Frq As Long
Public AdjIndex As Long
Public Adjs As Collection
Private Sub Class_Initialize()
Set Adjs = New Collection
End Sub
In your module, the tasks could be coded as follows:
Dim data As Variant, adj As Variant
Dim uniques As Collection, chains As Collection, chain As Collection
Dim oItem As cItem, oAdj As cItem
Dim r As Long, c As Long, n As Long, i As Long, maxChain As Long
Dim output() As Variant
'Read the data.
'Note: Define range as you need.
With Sheet1
data = .Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 12) _
.Value2
End With
'Find the unique values
Set uniques = New Collection
For r = 1 To UBound(data, 1)
For c = 1 To UBound(data, 2)
If IsEmpty(data(r, c)) Then Exit For
Set oItem = Nothing: On Error Resume Next
Set oItem = uniques(CStr(data(r, c))): On Error GoTo 0
If oItem Is Nothing Then
Set oItem = New cItem
oItem.Element = CStr(data(r, c))
uniques.Add oItem, oItem.Element
End If
oItem.Frq = oItem.Frq + 1
'Find the left adjacent value
If c > 1 Then
On Error Resume Next
oItem.Adjs.Add uniques(CStr(data(r, c - 1))), CStr(data(r, c - 1))
On Error GoTo 0
End If
'Find the right adjacent value
If c < UBound(data, 2) Then
If Not IsEmpty(data(r, c + 1)) Then
On Error Resume Next
oItem.Adjs.Add uniques(CStr(data(r, c + 1))), CStr(data(r, c + 1))
On Error GoTo 0
End If
End If
Next
Next
'Define the adjacent indexes.
For Each oItem In uniques
'If the item has a chain index, pass it to the adjacents.
If oItem.AdjIndex <> 0 Then
For Each oAdj In oItem.Adjs
oAdj.AdjIndex = oItem.AdjIndex
Next
Else
'If an adjacent has a chain index, pass it to the item.
i = 0
For Each oAdj In oItem.Adjs
If oAdj.AdjIndex <> 0 Then
i = oAdj.AdjIndex
Exit For
End If
Next
If i <> 0 Then
oItem.AdjIndex = i
For Each oAdj In oItem.Adjs
oAdj.AdjIndex = i
Next
End If
'If we're still missing a chain index, create a new one.
If oItem.AdjIndex = 0 Then
n = n + 1
oItem.AdjIndex = n
For Each oAdj In oItem.Adjs
oAdj.AdjIndex = n
Next
End If
End If
Next
'Populate the chain lists.
Set chains = New Collection
For Each oItem In uniques
Set chain = Nothing: On Error Resume Next
Set chain = chains(CStr(oItem.AdjIndex)): On Error GoTo 0
If chain Is Nothing Then
'It's a new chain so create a new collection.
Set chain = New Collection
chain.Add oItem.Element, CStr(oItem.Element)
chains.Add chain, CStr(oItem.AdjIndex)
Else
'It's an existing chain, so find the frequency position (highest first).
Set oAdj = uniques(chain(chain.Count))
If oItem.Frq <= oAdj.Frq Then
chain.Add oItem.Element, CStr(oItem.Element)
Else
For Each adj In chain
Set oAdj = uniques(adj)
If oItem.Frq > oAdj.Frq Then
chain.Add Item:=oItem.Element, Key:=CStr(oItem.Element), Before:=adj
Exit For
End If
Next
End If
End If
'Get the column count of output array
If chain.Count > maxChain Then maxChain = chain.Count
Next
'Populate each row with the relevant chain
ReDim output(1 To UBound(data, 1), 1 To maxChain)
For r = 1 To UBound(data, 1)
Set oItem = uniques(CStr(data(r, 1)))
Set chain = chains(CStr(oItem.AdjIndex))
c = 1
For Each adj In chain
output(r, c) = adj
c = c + 1
Next
Next
'Write the output to sheet.
'Note: adjust range to suit.
Sheet1.Range("M2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
This isn't the most efficient way of doing it, but it does make each task more obvious to you. I'm not sure I understood the full complexities of your data structure, but the code above does reproduce your sample, so it should give you something to work with.
Update
Okay, now I've seen your comments and the real data, below is some revised code which should be quicker and deals with the fact that the apparently 'empty' cells are actually null strings.
First of all create a class called cItem and add code behind:
Option Explicit
Public Name As String
Public Frq As Long
Public Adj As Collection
Private mChainIndex As Long
Public Property Get ChainIndex() As Long
ChainIndex = mChainIndex
End Property
Public Property Let ChainIndex(val As Long)
Dim oItem As cItem
If mChainIndex = 0 Then
mChainIndex = val
For Each oItem In Me.Adj
oItem.ChainIndex = val
Next
End If
End Property
Public Sub AddAdj(oAdj As cItem)
Dim t As cItem
On Error Resume Next
Set t = Me.Adj(oAdj.Name)
On Error GoTo 0
If t Is Nothing Then Me.Adj.Add oAdj, oAdj.Name
End Sub
Private Sub Class_Initialize()
Set Adj = New Collection
End Sub
Now create another class called cChain with code behind as:
Option Explicit
Public Index As Long
Public Members As Collection
Public Sub AddItem(oItem As cItem)
Dim oChainItem As cItem
With Me.Members
Select Case .Count
Case 0 'First item so just add it.
.Add oItem, oItem.Name
Case Is < 12 'Fewer than 12 items, so add to end or in order.
Set oChainItem = .item(.Count)
If oItem.Frq <= oChainItem.Frq Then 'It's last in order so just add it.
.Add oItem, oItem.Name
Else 'Find its place in order.
For Each oChainItem In Me.Members
If oItem.Frq > oChainItem.Frq Then
.Add oItem, oItem.Name, before:=oChainItem.Name
Exit For
End If
Next
End If
Case 12 'Full list, so find place and remove last item.
Set oChainItem = .item(12)
If oItem.Frq > oChainItem.Frq Then
For Each oChainItem In Me.Members
If oItem.Frq > oChainItem.Frq Then
.Add oItem, oItem.Name, before:=oChainItem.Name
.Remove 13
Exit For
End If
Next
End If
End Select
End With
End Sub
Private Sub Class_Initialize()
Set Members = New Collection
End Sub
Finally, your module code would be:
Option Explicit
Public Sub ProcessSheet()
Dim data As Variant
Dim items As Collection, chains As Collection
Dim oItem As cItem, oAdj As cItem
Dim oChain As cChain
Dim txt As String
Dim r As Long, c As Long, n As Long
Dim output() As Variant
Dim pTick As Long, pCount As Long, pTot As Long, pTask As String
'Read the data.
pTask = "Reading data..."
Application.StatusBar = pTask
With Sheet1
data = .Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp)) _
.Resize(, 12) _
.Value2
End With
'Collect unique and adjacent values.
pTask = "Finding uniques "
pCount = 0: pTot = UBound(data, 1): pTick = 0
Set items = New Collection
For r = 1 To UBound(data, 1)
If ProgressTicked(pTot, pCount, pTick) Then
Application.StatusBar = pTask & pTick & "%"
DoEvents
End If
For c = 1 To UBound(data, 2)
txt = data(r, c)
If Len(txt) = 0 Then Exit For
Set oItem = GetOrCreateItem(items, txt)
oItem.Frq = oItem.Frq + 1
'Take adjacent on left.
If c > 1 Then
txt = data(r, c - 1)
If Len(txt) > 0 Then
Set oAdj = GetOrCreateItem(items, txt)
oItem.AddAdj oAdj
End If
End If
'Take adjacent on right.
If c < UBound(data, 2) Then
txt = data(r, c + 1)
If Len(txt) > 0 Then
Set oAdj = GetOrCreateItem(items, txt)
oItem.AddAdj oAdj
End If
End If
Next
Next
'Now that we have all the items and their frequencies,
'we can find the adjacent chain indexes by a recursive
'call of the ChainIndex set property.
pTask = "Find chain indexes "
pCount = 0: pTot = items.Count: pTick = 0
Set chains = New Collection
n = 1 'Chain index.
For Each oItem In items
If ProgressTicked(pTot, pCount, pTick) Then
Application.StatusBar = pTask & pTick & "%"
DoEvents
End If
If oItem.ChainIndex = 0 Then
oItem.ChainIndex = n
Set oChain = New cChain
oChain.Index = n
chains.Add oChain, CStr(n)
n = n + 1
End If
Next
'Build the chains.
pTask = "Build chains "
pCount = 0: pTot = items.Count: pTick = 0
For Each oItem In items
If ProgressTicked(pTot, pCount, pTick) Then
Application.StatusBar = pTask & pTick & "%"
DoEvents
End If
Set oChain = chains(CStr(oItem.ChainIndex))
oChain.AddItem oItem
Next
'Write the data to our output array.
pTask = "Populate output "
pCount = 0: pTot = UBound(data, 1): pTick = 0
ReDim output(1 To UBound(data, 1), 1 To 12)
For r = 1 To UBound(data, 1)
If ProgressTicked(pTot, pCount, pTick) Then
Application.StatusBar = pTask & pTick & "%"
DoEvents
End If
Set oItem = items(data(r, 1))
Set oChain = chains(CStr(oItem.ChainIndex))
c = 1
For Each oItem In oChain.Members
output(r, c) = oItem.Name
c = c + 1
Next
Next
'Write the output to sheet.
'Note: adjust range to suit.
pTask = "Writing data..."
Application.StatusBar = pTask
Sheet1.Range("M2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
Application.StatusBar = "Ready"
End Sub
Private Function GetOrCreateItem(col As Collection, key As String) As cItem
Dim obj As cItem
'If the item already exists then return it,
'otherwise create a new item.
On Error Resume Next
Set obj = col(key)
On Error GoTo 0
If obj Is Nothing Then
Set obj = New cItem
obj.Name = key
col.Add obj, key
End If
Set GetOrCreateItem = obj
End Function
Public Function ProgressTicked(ByVal t As Long, ByRef c As Long, ByRef p As Long) As Boolean
c = c + 1
If Int((c / t) * 100) > p Then
p = p + 1
ProgressTicked = True
End If
End Function

XamDataGrid GroupByEvaluator Date Sorting vb.net

I've been trying to implement some custom grouping with Infragistics xamDataGrid (Infragistics3.Wpf.DataPresenter.v9.1.Express), and pretty much cribbed the entire bit of code from the Infragistics site. I have two different date fields -- Due Date, and Reminder Date -- using GroupByEvaluator. Everything seemed well and good until I tried to add both fields to the GroupByArea.
What happens is this: the nested field groups according to the date of the parent field as opposed to grouping of the parent field. For example, when I drag the "Due Date" (parent) field to the GroupBy, it'll group these records by Due Date into four categories -- Due Next Year, Due This Year, Past Due, and Not Set. Perfect. But when I drag the "Reminder Date" field (nested) to the GroupBy, I'll find multiple labels of the same "Reminder Date" grouping nested under Due Date "Past Due".
I'm a newbie posting to SO, so I can't post an image. Instead, I'll type one out:
Past Due (Due Date)
Not Set (Reminder Date)
This Month (Reminder Date)
Not Set (Reminder Date)
Older (Reminder Date)
Not Set (Reminder Date)
etc....
With each subsequent nested grouping, the earliest Due Date (value of the parent grouping) is equal to or greater than the greatest Due Date of the previous grouping. It appears as though the "Past Due" collection is sorted by Due Date asc, and it's iterating through each record and creating a new nested group whenever there is a change in the nested label. So after 5 groupByRecords are given the label of "This Month", when the next "Not Set" groupByRecord pops up a new nested label is created instead of continuing to populate the existing one.
I'm having a related issue with sorting, which I suspect is what this entire issue hinges on. If the grid has been sorted according to Due Date, all of the sort by functionality of the other fields are constrained by the Due Dates. For example, sorting by client name will not sort all client name records into ascending or descending. Instead, it will sort, but it sort by Due Date first, and then Name.
Sorry I can't attach an image. Hopefully I explained the issue okay.
Thanks in advance! Code below:
Imports System.Collections.ObjectModel
Imports Infragistics.Windows.DataPresenter
Imports System.Windows
Imports System.Windows.Controls
Partial Public Class ManageEntities
Public Sub New()
' This call is required by the designer.
InitializeComponent()
' Add any initialization after the InitializeComponent() call.
Me.InitializeGroupByGrid()
End Sub
#Region "CustomGrouping"
'http://help.infragistics.com/Help/Doc/WPF/2012.2/CLR4.0/html/InfragisticsWPF4.DataPresenter.v12.2~Infragistics.Windows.DataPresenter.IGroupByEvaluator.html
Private Sub InitializeGroupByGrid()
For Each f In Me.SelectorGrid.FieldLayouts(0).Fields
If f.Name = "Form1DueDate" OrElse f.Name = "Form1LastReminderDate" Then
f.Settings.GroupByEvaluator = New CustomDateTimeEvaluator
' group by the data field
Dim fsd As FieldSortDescription = New FieldSortDescription()
fsd.Field = f
fsd.Direction = System.ComponentModel.ListSortDirection.Descending
Me.SelectorGrid.FieldLayouts(0).SortedFields.Add(fsd)
End If
Next
End Sub
#End Region
End Class
#Region "CustomDateTimeEvaluator"
'//20150918 - From infragistics: http://help.infragistics.com/Help/Doc/WPF/2013.1/CLR4.0/html/InfragisticsWPF4.DataPresenter.v13.1~Infragistics.Windows.DataPresenter.IGroupByEvaluator.html
Friend Class CustomDateTimeEvaluator
Implements IGroupByEvaluator
Private Const NotSet As String = "Not Set"
Private Const PastDue As String = "Past Due"
Private Const DueThisYear As String = "Due This Year"
Private Const DueNextYear As String = "Due Next Year"
Private Const RemindThisMonth As String = "This Month"
Private Const RemindLastMonth As String = "Last Month"
Private Const Older As String = "Older"
Dim targetDate As DateTime = Nothing
Public Function DoesGroupContainRecord(ByVal groupByRecord As GroupByRecord, ByVal record As DataRecord) As Boolean Implements IGroupByEvaluator.DoesGroupContainRecord
Dim cellValue As Object = record.GetCellValue(groupByRecord.GroupByField)
Dim desc As String = groupByRecord.Description
' handle null values specially
If cellValue Is Nothing Or TypeOf cellValue Is DBNull Then
Return desc = NotSet
End If
' if the value is not a date time, just group them together
If TypeOf cellValue Is DateTime = False Then
Return True
End If
Return desc = GetDateLabel(CType(cellValue, DateTime), groupByRecord.GroupByField.Name)
End Function
Public Function GetGroupByValue(ByVal groupByRecord As GroupByRecord, ByVal record As DataRecord) As Object Implements IGroupByEvaluator.GetGroupByValue
Dim cellValue As Object = record.GetCellValue(groupByRecord.GroupByField)
Dim desc As String = String.Empty
Dim targetDate As DateTime = DateTime.MinValue
If cellValue Is Nothing Or TypeOf cellValue Is DBNull Then
desc = NotSet
ElseIf TypeOf cellValue Is DateTime Then
targetDate = CType(cellValue, DateTime)
desc = GetDateLabel(targetDate, groupByRecord.GroupByField.Name)
End If
groupByRecord.Description = desc
Return targetDate
End Function
Public ReadOnly Property SortComparer() As System.Collections.IComparer Implements IGroupByEvaluator.SortComparer
Get
Return Nothing
End Get
End Property
Private Function GetDateLabel(ByVal dt As DateTime, ByVal fldName As String) As String
Dim d As String = NotSet
Dim comparison As Integer = Nothing
Dim currentYear As Integer = DatePart(DateInterval.Year, Now)
'//If no date, return NotSet
If dt.Ticks = 0 Then
Return d
End If
'//Group by fieldname name
If fldName.ToLower = "form1duedate" Then
'//Past Due includes any records where the Form 1 Due Date is less than July 1st of the current year
Dim cDDate As New DateTime(currentYear, 7, 1)
comparison = dt.Date.CompareTo(cDDate.Date)
If comparison = 0 Then
d = DueThisYear
ElseIf comparison < 0 Then
d = PastDue
ElseIf comparison > 0 Then
d = DueNextYear
Else
d = NotSet
End If
ElseIf fldName.ToLower = "form1lastreminderdate" Then
Dim currentMonth As Integer = DatePart(DateInterval.Month, Now)
Dim olderThanDate As New DateTime(currentYear, currentMonth - 1, 1)
If dt.Date.Year = currentYear AndAlso dt.Date.Month = currentMonth Then
d = RemindThisMonth
ElseIf dt.Date.Year = currentYear AndAlso dt.Date.Month = currentMonth - 1 Then
d = RemindLastMonth
ElseIf dt.Date < olderThanDate Then
d = Older
Else
d = NotSet
End If
End If
Return d
End Function
End Class
#End Region

"if then statement in VBA to fill cell with number"

"if then statement in VBA" I'm writing a program that puts a number in a cell in Excell if a variable reaches a certain value. I understand how to declare variables but I don't know how to tell excel to write x if A1 =34. Thanks
Add a listener to your worksheet to capture a Range. You can make the range [A1] if you are only watching a specific column/row, or you can add a range like I have below.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Value = "34" Then
Cells(Target.Row, 2) = "X"
Else
Cells(Target.Row, 2) = ""
End If
End If
End Sub
Change "x" to if you want variable x and not literal x.
If your goal is to change the value of the cell to "X" (Literal X), and you are not having macros run constantly or with each cell change, you can use the following function (or similar) in each cell in which you have a conditional.
See the Microsoft support on this topic https://support.microsoft.com/en-us/kb/213612
It's not clear what you wish to do, but let's say you want to write the current value of your variable, x, into cell B2... if cell A1 is 34.
In the above case, you would do this:
If [a1] = 34 then [b2] = x
Private Sub CommandButton1_Click()
Dim lr As Long
lr = Worksheets("New").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("New").Range("T2").Formula = "=LEFT(B2,2)"
Worksheets("New").Range("T2").AutoFill Destination:=Worksheets("New").Range("T2:T" & lr)
Worksheets("New").Range("U2").Formula = "=(T2&0&0)"
Worksheets("New").Range("U2").AutoFill Destination:=Worksheets("New").Range("U2:U" & lr)
Worksheets("New").Range("V2").Formula = "=IF(AND(a2=A1,U2=U1),"",A2")" (HOW TO AUTO FILL THIS FORMULA IN A CELL)
Worksheets("New").Range("V2").AutoFill Destination:=Worksheets("New").Range("V2:V" & lr)
End Sub

How do I create a list in cells choosing from a combobox and selecting a button using VBA?

I have a combobox filled with values. I want to select a value in the combo box and click the "Add" button to place this value into the some cells below. I can add one item to my list using the following code, but I want to be able to add multiple items. I feel that I am very close, I just need a few tweaks!
Private Sub CommandButtonAddItem_Click()
Dim ws As Worksheet
Dim box As ComboBox
Dim food As String
Dim num As Integer
num = 19
Set ws = Worksheets("sheet1")
Set box = ws.OLEObjects("ComboBox1").Object
food = box.Value
Worksheets("sheet1").Cells(num, 1) = food
If Worksheets("sheet1").Cells(num, 1) = " " Then
Worksheets("sheet1").Cells(num, 1) = food
num = num + 1
End If
End Sub
Try THIS!
If the "default" cell is already occupied, it'll keep going down untill it finds one that's not empty, to then put the value in that cell.
Private Sub CommandButtonAddItem_Click()
Dim ws As Worksheet
Dim box As ComboBox
Dim food As String
Dim num As Integer
num = 19
Set ws = Worksheets("sheet1")
Set box = ws.OLEObjects("ComboBox1").Object
food = box.Value
While Worksheets("sheet1").Cells(num, 1) <> ""
num = num + 1
Wend
Worksheets("sheet1").Cells(num, 1) = food
End If
End Sub

How to emulate .net Int64 in VB6?

How can store an Int64 number in VB6, to work with Win32 functions?
Is there a way to define a type like Int64 in .net? And simply evaluate the number.
I think many of VB6 programmers need something like this,
Because some of the Win32 API's use _int64 as their parameters.
I wrote a function to cast a currency into an API compatible structure.
Put these codes in a module file.
Private Declare Sub CopyMemory lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const SIZEOF_INT64 As Long = 8
Public Type Int64 'LowPart must be the first one in LittleEndian systems
'required part
LowPart As Long
HighPart As Long
'optional part
SignBit As Byte 'define this as long if you want to get minimum CPU access time.
End Type
'with the SignBit you can emulate both Int64 and UInt64 without changing the real sign bit in HighPart.
'but if you want to change it you can access it like this mySign = (myVar.HighPart And &H80000000)
'or turn on the sign bit using myVar.HighPart = (myVar.HighPart Or &H80000000)
Public Function CInt64(ByVal vCur As Currency) As Int64
vCur = (CCur(vCur) * 0.0001#)
Call CopyMemory(CInt64, vCur, SIZEOF_INT64)
End Function
Now you can simply use CInt64 to create an Int64 number.
ex:
myRetVal = Win32APIFunctionWithOneInt64Param(CInt64(10000000))
'----OR
Dim myNum As Int64
myNum = CInt64(10000000)
And for more operations:
Public Sub Op_Ev(Dest As Int64, Src As Int64) 'for setting the value.
Call CopyMemory(Dest, Src, SIZEOF_INT64)
End Sub
Public Function Op_Eq(V1 As Int64, V2 As Int64) As Boolean 'for equal comparison.
Op_Eq = (V1.LowPart = V2.LowPart) : If Not Op_Eq Then Exit Function
Op_Eq = (V1.HighPart = V2.HighPart)
End Function
Public Function Op_Gr(V1 As Int64, V2 As Int64, Optional ByVal IsUnsignedComparison As Boolean = False) As Boolean 'for grater comparison.
If IsUnsignedComparison Then
Dim H1 As Long, H2 As Long 'don't change the location of these definitions to optimize the function to prevent to execute two or more {SUB ESP, 4}
H1 = (V1.HighPart And &H7FFFFFFF) : H2 = (V2.HighPart And &H7FFFFFFF)
Op_Gr = (H1 > H2) : If (H1 <> H2) Then Exit Function
Dim HBS1 As Long, HBS2 As Long 'don't change the type of these two vars to byte to keep alignment for local variables.
HBS1 = ((V1.HighPart And &H80000000) / &H80000000) 'export the sign bit and shift it to the right.
HBS2 = ((V2.HighPart And &H80000000) / &H80000000) 'export the sign bit and shift it to the right.
Op_Gr = (HBS1 > HBS2) : If (HBS1 <> HBS2) Then Exit Function
Else
Op_Gr = (V1.HighPart > V2.HighPart) : If (V1.HighPart <> V2.HighPart) Then Exit Function
End If
Op_Gr = (V1.LowPart > V2.LowPart)
End Function
Public Function Op_Ls(V1 As Int64, V2 As Int64, Optional ByVal IsUnsignedComparison As Boolean = False) As Boolean 'for less comparison.
If IsUnsignedComparison Then
Dim H1 As Long, H2 As Long 'don't change the location of these definitions to optimize the function to prevent to execute two or more {SUB ESP, 4}
H1 = (V1.HighPart And &H7FFFFFFF) : H2 = (V2.HighPart And &H7FFFFFFF)
Op_Ls = (H1 < H2) : If (H1 <> H2) Then Exit Function
Dim HBS1 As Long, HBS2 As Long 'don't change the type of these two vars to byte to keep alignment for local variables.
HBS1 = ((V1.HighPart And &H80000000) / &H80000000) 'export the sign bit and shift it to the right.
HBS2 = ((V2.HighPart And &H80000000) / &H80000000) 'export the sign bit and shift it to the right.
Op_Ls = (HBS1 < HBS2) : If (HBS1 <> HBS2) Then Exit Function
Else
Op_Ls = (V1.HighPart < V2.HighPart) : If (V1.HighPart <> V2.HighPart) Then Exit Function
End If
Op_Ls = (V1.LowPart < V2.LowPart)
End Function
Public Function Op_Cmp(V1 As Int64, V2 As Int64, Optional ByVal IsUnsignedComparison As Boolean = False) As Long 'for comparison.
If Op_Gr(V1, V2, IsUnsignedComparison) Then
Op_Cmp = 1
ElseIf Op_Ls(V1, V2, IsUnsignedComparison) Then
Op_Cmp = -1
Else
Op_Cmp = 0
End If
End Function