-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配列は、Status、の一意の組み合わせを設定しますが、オブジェクトGroupがTime関連付けられると、関連付けが解除されるまで関連付けられたままになるため、問題にはなりません。

私はこれに関するヘルプを探しましたが、ほとんどの投稿は配列の作成についてのみ説明しており、関連付けが解除されたときにループがエントリを自動的に削除するのにどのように役立つかについては説明していません。

したがって、この例では、オブジェクト # と時刻を入力してスクリプトを実行し、最後に「時刻 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

あなたと私が何度かやり取りした後、これが最初に理解したよりも複雑な要求であることがわかりました. オブジェクトを使用する別の方法を次に示しScripting.Dictionaryます。基本的に、これにより、一意の「キー」をコレクションに追加/削除できます。この場合、キー値として Group# を使用することを選択しました。これは、これが一意の関連付けである必要があることを示しているためです (たとえば、Obj1 が時間 1 でグループ 1 に関連付けられ、時間 2 でグループ 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
于 2013-02-19T16:39:23.677 に答える
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 に答える