Question

I am trying to figure out how I can use VBA to create an array from Excel data as an active list that can have unique entries added and removed automatically as my script runs through a loop.

Example:

Object#   ,  Status     ,   Group#  ,  Time            
1      ,     Associate     , 1        , 1  
1      ,     Associate     , 1        , 1.1  
1      ,     Associate     , 2        , 2   
1      ,     Associate     , 3        , 3  
1      ,     Disassociate  , 2        , 4

The array would populate unique combinations of Object, Status, and Group but Time would not matter because once an object is associated it will remain associated until it is disassociated.

I have looked for help on this but most posts only discuss populating the array and do not discuss how a loop could help to automatically remove an entry when it is disassociated.

So in this example I would want an system that would allow me to enter the object # and time then the script would run and at the end it would tell me that “At time 4, object 1 is associated with groups 1 and 3”. An alternate scenario would be “At time 3, object 1 is associated with groups 1, 2, 3”. Finally, if at time 5 all objects were disassociated the the message would display the last group the object was associated to.

I have a code that does everything I need until it runs into a situation where an object is associated to more than one group then it fails to return accurate information. My programming knowledge is limited so your help is appreciated. Below is the code I have currently where Cells (15, 8) and (18, 8) are value input cells for Object # and Time.

Private Sub CommandButton2_Click()
Dim Association As String, i As Integer, Group As Integer

Count = Application.WorksheetFunction.CountA(Range("A:A"))

For i = 1 To Count 

    If Cells (i, 1).Value = Cells(15, 8) And Cells (i, 4).Value <= Cells (18, 8) And Cells (i, 2) = "Associate"  Then Association = "Associated" 

    If Cells (i, 1).Value = Cells(15, 8) And Cells (i, 4).Value <= Cells (18, 8) And Cells (i, 2) = "Disassociate"  Then Association = "NOT Associated"

    If Cells (i, 1).Value = Cells(15, 8) And Cells (i, 4).Value <= Cells (18, 8) And Cells (i, 2) = "Associate"  Then Group = Cells(i, 3)

Next i

    If Association = "Associated" Then MsgBox Association & " Associated to " & Group
    If Association = "NOT Associated" Then Msgbox Association & " Was Last Associated to " & Group
    If Association = "" Then Msgbox "Object Does Not Exist Prior to This Time"

End Sub

Answer 1

After some back-and-forth you & I discover that this is a more complicated request than we had initially understood it. Here is another method that uses a Scripting.Dictionary object — basically this allows you to add/remove unique “Keys” to a collection. In this case I chose to use Group# as the KEY value, because you indicate that this should be the unique association (e.g., if Obj1 is associated to Group 1 at Time 1 and Group 1 at Time 2, we only care about the first association to Group 1). Further we assume that Time is always sorted ascending.

Scripting.Dictionary seems perhaps a little easier than trying to resize arrays for your add/remove.

At the end, we set some simple arrays dicKeys and dicItems, over which we can iterate to present the message box information to user. In your example, it will create a message box as follows:

Here is the code:

Option Explicit

Private Sub GroupAssociation()
'ASSUMPTIONS: GroupNum is the UNIQUE key
'ASSUMPTIONS: TimeVal always sort ascending

'Parameters for our test:
Dim ObjNum As Integer  'cells(15,5)
Dim TimeStamp As Double 'cells(15,8)

'Fields being iterated over, in columns A:D
Dim i As Integer    'row counter/iterator
Dim count As Long   'row count/max range
Dim ObjTest As Integer 'the object number being tested, from column A, cells(i,1)
Dim Status As String  'cells(i,2)
Dim GroupNum As Integer  'cells(1,3)
Dim TimeVal As Double  'Cells(i,4)

'We will store the information, uniquely in a Scripting.Dictionary
Dim objDic As Object 'Scripting dictionary to contain your information
Dim dicKeys As Variant 'list of key items in the dictionary
Dim dicItems As Variant 'list of items in dictionary
Dim o As Long 'counter/iterator for dicKeys

'A message box will display the results
Dim mbString As String 'to contain the message box string

Set objDic = Nothing 'make sure this is nothing, just in case.
Set objDic = CreateObject("Scripting.Dictionary")

count = Application.WorksheetFunction.CountA(Range("A:A"))

ObjNum = Cells(15, 8).Value
TimeStamp = Cells(18, 8).Value

For i = 2 To count
    ObjTest = Cells(i, 1).Value
    Status = Cells(i, 2).Value
    GroupNum = Cells(i, 3).Value
    TimeVal = Cells(i, 4).Value
    dicKeys = objDic.Keys

    If ObjTest = ObjNum And TimeVal <= TimeStamp Then
        If Status = "Associate" Then
            'Check to see if this Key already exists, if so ignore, if not, add to dic.
            If UBound(dicKeys) < 0 Then
                objDic.Add GroupNum, "Object #" & ObjTest & _
                    " Associated to Group #" & GroupNum & " at time " & TimeVal
            Else:
                If IsError(Application.Match(GroupNum, dicKeys, False)) Then
                    objDic.Add GroupNum, "Object #" & ObjTest & _
                    " Associated to Group #" & GroupNum & " at time " & TimeVal
                End If
            End If
        ElseIf Status = "Disassociate" Then
            'Check to see if this Key already exists, if so, remove it
            If Not IsError(Application.Match(GroupNum, dicKeys, False)) Then
                'remove the item as it was
                objDic.Remove GroupNum
                'add a new item indicating it's new status as disassociated
                objDic.Add GroupNum, "Object #" & ObjTest & _
                " Disassociated from Group #" & GroupNum & " at time " & TimeVal
            End If
        End If
    End If

Next i

'Set some arrays from our Dictionary items:
dicKeys = objDic.Keys
dicItems = objDic.Items

'iterate over the array and build our message box string:
For o = 0 To UBound(dicKeys)
    If mbString = vbNullString Then
        mbString = dicKeys(o) & " - " & dicItems(o)
    Else:
        mbString = mbString & vbCrLf & _
           dicKeys(o) & " - " & dicItems(o)
    End If
Next

'handle cases where the item doesn't exist prior to this timestamp:
If mbString = vbNullString Then mbString = "Object #" & ObjNum & _
    " doesn't exist prior to time " & TimeStamp

'Show the message box:
MsgBox mbString, vbInformation

Set objDic = Nothing

End Sub