使用数组作为 Excel 数据 VBA 中具有唯一值的活动列表

Question

我试图弄清楚如何使用 VBA 从 Excel 数据创建一个数组作为活动列表，当我的脚本通过循环运行时，可以自动添加和删除唯一条目。

例子：

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

该数组将填充 Object、Status 和 Group 的唯一组合，但 Time 无关紧要，因为一旦关联对象，它将保持关联，直到取消关联。

我已经在这方面寻求帮助，但大多数帖子只讨论填充数组，并没有讨论循环如何帮助在解除关联时自动删除条目。

所以在这个例子中，我想要一个允许我输入对象 # 和时间的系统，然后脚本会运行，最后它会告诉我“在时间 4，对象 1 与组 1 和3"。另一种情况是“在时间 3，对象 1 与组 1、2、3 相关联”。最后，如果在时间 5 取消所有对象的关联，则消息将显示该对象关联到的最后一个组。

我有一个代码可以完成我需要的一切，直到它遇到一个对象与多个组相关联的情况，然后它无法返回准确的信息。我的编程知识有限，因此感谢您的帮助。下面是我目前拥有的代码，其中 Cells (15, 8) 和 (18, 8) 是 Object # 和 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

经过你我的反复讨论，我发现这是一个比我们最初理解的更复杂的请求。这是另一种使用Scripting.Dictionary 对象的方法——基本上这允许您向集合添加/删除唯一的“键”。在这种情况下，我选择使用 Group# 作为 KEY 值，因为您指出这应该是唯一关联（例如，如果 Obj1 在时间 1 关联到 Group 1，在 Time 2 关联到 Group 1，我们只关心第一个关联到第 1 组）。此外，我们假设 Time 始终按升序排序。

Scripting.Dictionary 似乎比尝试为添加/删除调整数组大小要容易一些。

最后，我们设置了一些简单的数组dicKeys 和dicItems，我们可以在这些数组上进行迭代以将消息框信息呈现给用户。在您的示例中，它将创建一个消息框，如下所示：

代码如下：

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

Answer 2

你大部分时间都在那里。对于此示例，我将 Dim Group as String 并构建一个简单的逗号分隔列表以允许多个关联。您可以将它存储为一个数组并转置它，但我不确定这是否有必要。

我声明了更多变量以方便进行更清洁/整洁的“测试”，并支持Select Case 而不是多个 IF/THEN 用于消息框结果。

Private Sub Groups()
Dim Association As String
Dim i As Integer
Dim Group As String 'will contain the message
Dim ObjNum As Integer  'cells(15,5)
Dim TimeStamp As Double 'cells(15,8)
Dim ObjTest As Integer
Dim Status As String  'cells(i,2)
Dim GroupNum As Integer  'cells(1,3)
Dim TimeVal As Double  'Cells(i,4)

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

    If ObjTest = ObjNum And TimeVal <= TimeStamp Then
        If Status = "Associate" Then
            Association = "Associated"
            'Build a simple comma-delimited string of group associations, to allow
            ' for multiple associations
            Group = PrintMessage(Group, GroupNum & " at time " & TimeVal)
        ElseIf Status = "Disassociate" Then
            Association = "NOT Associated"
        End If
    End If

Next i

Select Case Association
    Case "Associated"
        MsgBox "Object # " & ObjNum & " Associated to: " & vbCrLf & Group
    Case "NOT Associated"
        MsgBox "Object # " & ObjNum & " Was Last Associated to: " & vbCrLf & Group
    Case vbNullString, ""
        MsgBox "Object " & ObjNum & " Does Not Exist Prior to This Time"
End Select

End Sub


Function PrintMessage(existingMsg$, GroupAtTimeString$) As String
If existingMsg = vbNullString Then
    PrintMessage = GroupAtTimeString
Else:
    PrintMessage = existingMsg & "," & vbCrLf & GroupAtTimeString
End If
End Function