Arrays 在VBA for Excel数据中将数组用作具有唯一值的活动列表_Arrays_Excel_List_Vba_For Loop

Arrays 在VBA for Excel数据中将数组用作具有唯一值的活动列表

arrays excel list vba for-loop

Arrays 在VBA for Excel数据中将数组用作具有唯一值的活动列表,arrays,excel,list,vba,for-loop,Arrays,Excel,List,Vba,For Loop,我正试图弄明白如何使用VBA从Excel数据创建一个数组，作为活动列表，在脚本通过循环运行时可以自动添加和删除唯一的条目例如： Object# , Status , Group# , Time 1 , Associate , 1 , 1 1 , Associate , 1 , 1.1 1 , Associate , 2 ,

我正试图弄明白如何使用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

数组将填充

对象

、

状态

和

组

的独特组合，但

时间

无关紧要，因为一旦对象关联，它将保持关联，直到解除关联为止

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

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

我有一个代码，它可以做我需要的一切，直到它遇到一个对象与多个组关联的情况，然后它无法返回准确的信息。我的编程知识有限，非常感谢您的帮助。下面是我目前的代码，其中单元格（15,8）和（18,8）是对象和时间的值输入单元格

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

Private子命令按钮2\u单击（）
Dim关联为字符串，i为整数，组为整数
Count=Application.WorksheetFunction.CountA（范围（“A:A”））
对于i=1进行计数
如果单元格（i，1）.Value=Cells（15，8）和Cells（i，4）.Value。对于本例，我将将组作为字符串进行Dim
，并构建一个简单的逗号分隔列表，以允许多个关联。您可以将其存储为数组并转置，但我不确定这是否必要
我声明了更多的变量，以便于进行更干净/整洁的“测试”，并对消息框结果支持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

Private子组（）
作为字符串的Dim关联
作为整数的Dim i
Dim Group As String'将包含消息
作为“整数”单元格的暗长方体（15,5）
Dim时间戳为双“单元（15,8）
Dim对象测试为整数
变暗状态为“字符串”单元格（i，2）
Dim GroupNum作为整数单元格（1,3）
Dim TimeVal作为双“单元（i，4）
Count=Application.WorksheetFunction.CountA（范围（“A:A”））
小圆=细胞（15，8）。数值
时间戳=单元格（18，8）。值
对于i=2进行计数
ObjTest=单元格（i，1）.值
状态=单元格（i，2）。值
GroupNum=单元格（i，3）.Value
TimeVal=单元格（i，4）.值
如果ObjTest=ObjNum和TimeVal经过反复的讨论，您&我发现这是一个比我们最初理解的更复杂的请求。下面是另一个使用Scripting.Dictionary
对象的方法——基本上这允许您向集合添加/删除唯一的“键”。在本例中，我选择使用组#作为键值，因为您指出这应该是唯一关联（例如，如果Obj1在时间1与组1关联，在时间2与组1关联，我们只关心与组1的第一个关联）。此外，我们假设时间总是按升序排列的
脚本.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

选项显式
私人分组协会（）
'假设：GroupNum是唯一的键
'假设：TimeVal始终按升序排序
“我们测试的参数：
作为“整数”单元格的暗长方体（15,5）
Dim时间戳为双“单元（15,8）
'正在迭代的字段，在A:D列中
Dim i作为整数行计数器/迭代器
“长”行计数/最大范围的变暗计数
Dim ObjTest As Integer'测试对象编号，来自A列单元格（i，1）
变暗状态为“字符串”单元格（i，2）
Dim GroupNum作为整数单元格（1,3）
Dim TimeVal作为双“单元（i，4）
'我们将唯一地将信息存储在脚本字典中
Dim objDic作为对象的脚本字典来包含您的信息
dicKeys作为字典中关键项的变体列表
Dim Dick items As Variant在字典中的项目列表
Dim o作为dicKeys的“长”计数器/迭代器
'消息框将显示结果
Dim mbString As String'以包含消息框字符串
设置objDic=Nothing'确保这是一个空值，以防万一。
设置objDic=CreateObject（“Scripting.Dictionary”）
count=Application.WorksheetFunction.CountA（范围（“A:A”））
小圆=细胞（15，8）。数值
时间戳=单元格（18，8）。值
对于i=2进行计数
ObjTest=单元格（i，1）.值
状态=单元格（i，2）。值
GroupNum=单元格（i，3）.Value
TimeVal=单元格（i，4）.值
dicKeys=objDic.Keys
如果ObjTest=ObjNum和TimeVal，为了简单起见，您能否与我们分享已经获得的代码？请编辑您的问题。这似乎非常接近我的需要，我非常感谢。我有两个问题要解决。1.同一关联可以有多个条目，因此当出现消息时，同一组会报告多个条目，即，如果对象1在两个不同的时间与组1关联，则我需要一条唯一的消息。“关联到第1组和第1组”与“关联到第1组”2.）当我输入一个小数点为200.26 vs 200的时间时，似乎我遇到了问题。有没有办法解决这个问题？再次感谢你的帮助！只要TimeVal
和TimeStamp
变量被标注为双精度变量，您就不应该对十进制有任何问题。如果是这样，你会