-1

我试图弄清楚如何使用 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，但无关紧要，因为一旦对象关联，它将保持关联，直到解除关联。StatusGroupTime

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

所以在这个例子中，我想要一个允许我输入对象 # 和时间的系统，然后脚本将运行，最后它会告诉我“在时间 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
4

2 回答 2

0

你大部分时间都在。对于此示例，我将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
于 2013-02-14T21:20:25.263 回答
0

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

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

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

msgbox 结果截图

这是代码：

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
于 2013-02-19T16:39:23.677 回答