2017年2月15日水曜日

VBA Arrayの論理計算、交集、並集(AND OR)(Intersection And Union)(Logical disjunction Logical conjunction)

Option Explicit
Sub testUnionAndIntersection()

'Intersection And Union
'Also called
'Logical disjunction Logical conjunction
'AND OR

Dim a As New Scripting.Dictionary
Dim b As New Scripting.Dictionary
Dim keysA As Variant
Dim keysB As Variant
Dim keysC As Variant
Dim keysD As Variant

a.Add "A", ""
a.Add "B", ""
a.Add "C", ""

b.Add "A", ""
b.Add "C", ""
b.Add "X", ""

keysA = a.Keys
keysB = b.Keys

keysC = getIntersectionSet(keysA, keysB)
Debug.Print Join(keysC, ",")
'A,C

keysD = getUnionSet(keysA, keysB)
Debug.Print Join(keysD, ",")
'A,B,C,X

Call DeleteElementAt(1, keysB)
Debug.Print Join(keysB, ",")
'A,X

End Sub
Function getIntersectionSet(arr1 As Variant, arr2 As Variant) As Variant
Dim vntTmp As Variant
Dim vntRst As Variant

If Not (IsArray(arr1) And IsArray(arr2)) Then
    Exit Function
End If

For Each vntTmp In arr1
    If IsInArray(CStr(vntTmp), arr2) Then
        push vntTmp, vntRst
    End If
Next

getIntersectionSet = vntRst

End Function
Function getUnionSet(arr1 As Variant, arr2 As Variant) As Variant
Dim vntTmp As Variant
Dim vntRst As Variant

If Not (IsArray(arr1) And IsArray(arr2)) Then
    Exit Function
End If

vntRst = arr1

For Each vntTmp In arr2
    If Not IsInArray(CStr(vntTmp), vntRst) Then
        push vntTmp, vntRst
    End If
Next

getUnionSet = vntRst

End Function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Public Sub DeleteElementAt(ByVal index As Integer, ByRef prLst As Variant)
       Dim i As Integer
        For i = index + 1 To UBound(prLst)
            prLst(i - 1) = prLst(i)
        Next
        ReDim Preserve prLst(UBound(prLst) - 1)
End Sub

Public Function push(ByVal val As Variant, ByRef arr As Variant, Optional ByVal unique As Boolean = False) As Integer
Dim lngX As Long
    If unique Then
        If Not IsEmpty(arr) Then
            If IsArray(arr) Then
                For lngX = LBound(arr) To UBound(arr)
                    If arr(lngX) = val Then
                        push = UBound(arr)
                        Exit Function
                    End If
                Next
            End If
        End If
    End If
    If IsArray(arr) Then
        On Error GoTo initArray
        ReDim Preserve arr(UBound(arr) + 1)
    Else
initArray:
        ReDim arr(0)
    End If
    If VarType(val) = 9 Then '9 is object
        Set arr(UBound(arr)) = val
    Else
        arr(UBound(arr)) = val
    End If
    push = UBound(arr)
End Function