Here is some long winded code that I have in an addin. It requires a few
things to get started. Create a User Form. Add two RefEdit Controls to the
userform and a command button. The names of the refedits is refRange1 and
refRange2. The command button is cmdOk. You also need to reference the
project to Microsoft Scripting Runtime (Tools | References | Check Microsoft
Scripting Runtime).
The form asks you to select two ranges. When you click ok it creates a new
sheet listing the differences in the two lists...
Private Sub cmdOk_Click()
Dim blnValidRanges As Boolean
Dim rngRange1 As Range
Dim rngRange2 As Range
Dim rngCurrent As Range
Dim Dic1 As Scripting.Dictionary 'Dictionary Object
Dim Dic2 As Scripting.Dictionary 'Dictionary Object
Dim varUnmatched1 As Variant 'Array of unmatched items
Dim varUnmatched2 As Variant 'Array of unmatched items
Dim wksNew As Worksheet
Dim lngCounter As Long
blnValidRanges = True
On Error Resume Next
Set rngRange1 = Range(refRange1.Text)
Set rngRange2 = Range(refRange2.Text)
On Error GoTo ErrorHandler
If rngRange1 Is Nothing Then
blnValidRanges = False
Call ControlError(refRange1)
ElseIf rngRange2 Is Nothing Then
blnValidRanges = False
Call ControlError(refRange2)
End If
If blnValidRanges = True Then
Set rngRange1 = Intersect(rngRange1.Parent.UsedRange, rngRange1)
Set rngRange2 = Intersect(rngRange2.Parent.UsedRange, rngRange2)
Set Dic1 = CreateDictionary(rngRange1)
Set Dic2 = CreateDictionary(rngRange2)
varUnmatched1 = UnmatchedArray(Dic1, Dic2)
varUnmatched2 = UnmatchedArray(Dic2, Dic1)
If IsArray(varUnmatched1) Or IsArray(varUnmatched2) Then
Set wksNew = Sheets.Add
With wksNew
.Range("A1").Value = refRange1.Text
.Range("B1").Value = refRange2.Text
Set rngCurrent = .Range("A2")
If IsArray(varUnmatched1) Then
For lngCounter = LBound(varUnmatched1) To
UBound(varUnmatched1)
rngCurrent.Value = varUnmatched1(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter
End If
Set rngCurrent = .Range("B2")
If IsArray(varUnmatched2) Then
For lngCounter = LBound(varUnmatched2) To
UBound(varUnmatched2)
rngCurrent.Value = varUnmatched2(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter
End If
End With
Else
MsgBox "There are no unmatched items.", vbOKOnly, "No Unmantched"
End If
End If
Unload Me
End Sub
Private Sub ControlError(ByVal RefControl As Control)
MsgBox "Please select a range to check", vbInformation, "Select Range"
With RefControl
.SelStart = 0
.SelLength = Len(.Text)
.Text = .SelText
.SetFocus
End With
End Sub
Private Function CreateDictionary(ByVal Target As Range) As
Scripting.Dictionary
Dim rngCurrent As Range
Dim dic As Scripting.Dictionary 'Dictionary Object
Set dic = New Scripting.Dictionary
For Each rngCurrent In Target
If Not dic.Exists(rngCurrent.Value) And rngCurrent.Value <> Empty
Then 'Check the key
dic.Add rngCurrent.Value, rngCurrent.Value 'Add the item if
unique
End If
Next rngCurrent
Set CreateDictionary = dic
End Function
Private Function UnmatchedArray(ByVal Dic1 As Scripting.Dictionary, _
ByVal Dic2 As Scripting.Dictionary) As Variant
Dim dicItem As Variant
Dim aryUnmatched() As String
Dim lngCounter As Long
lngCounter = 0
For Each dicItem In Dic1
If Not Dic2.Exists(dicItem) Then 'Check the key
ReDim Preserve aryUnmatched(lngCounter)
aryUnmatched(lngCounter) = dicItem
lngCounter = lngCounter + 1
End If
Next dicItem
If lngCounter = 0 Then
UnmatchedArray = Empty
Else
UnmatchedArray = aryUnmatched
End If
End Function
--
HTH...
Jim Thomlinson
"zwestbrook" wrote:
> I've searched on the forum and found ways to list duplicate items and
> unique items, but this is for a combination of two lists, not
> "bumping" one list against another. In this case, I need to compare
> List A to List B and return those items in List B that are not in List
> A. I scavenged and tweaked some code, but it is trying to do a cell-to-
> cell comparison - this won't work as items can be in different
> locations within the lists. Thoughts?
>
> Sub ListDuplicateVal()
>
> Dim Rng1 As Range
> Dim Rng2 As Range
> Dim Rng3 As Range
> Dim Cell As Range
>
> Set Rng1 = Range("A1:A13") 'long list
> Set Rng2 = Range("B1:B13") 'short list
> Set Rng3 = Range("D1") 'output
> On Error Resume Next
>
> For Each Cell In Rng2
>
> If Rng2.Cell.Value <> Rng1.Cell.Value Then
> Rng3.Value = Cell.Value
> Set Rng3 = Rng3.Offset(1, 0)
> End If
>
> Next Cell
> End Sub
>
|
Similar Threads
