View Single Post
  #6   Report Post  
Posted to microsoft.public.excel.programming
Bernie Deitrick Bernie Deitrick is offline
external usenet poster
 
Posts: 5,441
Default SET THEORY & VBA ?

Jay,

The code below requires a reference to MS Scripting Runtime....

The code works on columns A and C, with output to D and E for the intersection and union, and it
gives a msgbox for subset....

HTH,
Bernie
MS Excel MVP


Sub GetIntersection()
Dim myInt As Variant
Dim i As Integer
myInt = CommUniqueValues(Range("A1:A10"), Range("C1:C10"))
Range("D1").Resize(UBound(myInt) - LBound(myInt) + 1).Value = _
Application.Transpose(myInt)
End Sub

Sub GetUnion()
Dim myUnion As Variant
Dim i As Integer
myUnion = AllUniqueValues(Range("A1:A10"), Range("C1:C10"))
Range("E1").Resize(UBound(myUnion) - LBound(myUnion) + 1).Value = _
Application.Transpose(myUnion)
End Sub

Sub IsItASubSet()
'is the first range a subset of the second?
MsgBox "A is a subset of C is " & IsSubSet(Range("A1:A10"), Range("C1:C10"))
MsgBox "C is a subset of A is " &IsSubSet(Range("C1:C10"), Range("A1:A10"))
End Sub


Function CommUniqueValues(R1 As Range, r2 As Range) As Variant
Dim myVals As Variant
Dim C As Range

ReDim myVals(1 To 1)
myVals(1) = "Nothing Entered"
For Each C In R1
If Application.CountIf(Range(R1.Cells(1), C), C.Value) = 1 Then
If Not IsError(Application.Match(C.Value, r2, False)) Then
If myVals(1) = "Nothing Entered" Then
myVals(1) = C.Value
Else
ReDim Preserve myVals(1 To UBound(myVals) + 1)
myVals(UBound(myVals)) = C.Value
End If
End If
End If
Next C
CommUniqueValues = myVals
End Function

Function AllUniqueValues(R1 As Range, r2 As Range) As Variant
'This one requires the reference to Microsoft Scripting Runtime.
Dim Dict As Dictionary
Dim ItemCount As Integer
Dim myC As Range
Dim i As Integer

Set Dict = New Dictionary
With Dict
'set compare mode
.CompareMode = BinaryCompare

'add items from both ranges to the dictionary
For Each myC In R1
If Not .Exists(myC.Value) Then
.Add Key:=myC.Value, Item:=i
i = i + 1
End If
Next myC
For Each myC In r2
If Not .Exists(myC.Value) Then
.Add Key:=myC.Value, Item:=i
i = i + 1
End If
Next myC

AllUniqueValues = .Keys
End With
Set Dict = Nothing
End Function

Function IsSubSet(R1 As Range, r2 As Range) As Boolean
Dim myStr As String
Dim myVal As Integer

IsSubSet = False
myStr = "=SUMPRODUCT(ISERROR(MATCH(" & R1.Address & "," & r2.Address & ",FALSE))*1)"
myVal = Application.Evaluate(myStr)
If myVal = 0 Then IsSubSet = True
End Function


"jay dean" wrote in message ...
Thanks, Simon, Ossie Mac, and Sam for your responses.
@ Sam, yes, that was what I was looking for. I understand I can easily
combine any 2 loops like a For-For, For-Do, Do-For, While-For, etc, to
accomplish this, but for a large range I don't want to wait forever. I
thought VBA had efficient built-in functions like "ismember()"e.t.c as
Matlab does. Or, even formulas in Excel?

Anyway, for those who didn't understand what I was looking for: I was
talking about Mathematical Set Theory. Example:
1. rng1 "intersection" rng2 should yield a range containing "values"
common to values in both ranges.

2. rng1 "union" rng2 should yield a range containing values in each
range (without repetitions).

3. rng2 will be a subset of rng1, if all elements (values) in rng2 can
be found in rng1. In this case, the result will be a Boolean.."true" if
yes, and "false" if no.

Sorry, I didn't explain myself better.

Jay

*** Sent via Developersdex http://www.developersdex.com ***