ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Finding Unique Entries Among Two Columns (https://www.excelbanter.com/excel-programming/364977-re-finding-unique-entries-among-two-columns.html)

Jim Thomlinson
Finding Unique Entries Among Two Columns
 
Here is some code that I use (similar to anywayts). You MUST reference the
project to "Microsoft Scripting Runtime" (In the VBE Tools-References...)

Private Sub MatchedAandB()
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 varMatched As Variant 'Array of unmatched items
Dim wksNew As Worksheet
Dim lngCounter As Long

blnValidRanges = True

On Error Resume Next
Set rngRange1 = Intersect(UsedRange, range("A:A"))
Set rngRange2 = Intersect(UsedRange, range("B:B"))
Set Dic1 = CreateDictionary(rngRange1)
Set Dic2 = CreateDictionary(rngRange2)
varMatched = MatchedArray(Dic1, Dic2)
If IsArray(varMatched) Then
Set wksNew = Sheets.Add
With wksNew
.Range("A1").Value = "Matched Items"
Set rngCurrent = .Range("A2")
For lngCounter = LBound(varMatched) To UBound(varMatched)
rngCurrent.Value = varMatched(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter

End With
Else
MsgBox "No Matching Items", vbOKOnly, "No Matches"
End If

End If
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 MatchedArray(ByVal Dic1 As Scripting.Dictionary, _
ByVal Dic2 As Scripting.Dictionary) As Variant
Dim dicItem As Variant
Dim aryMatched() As String
Dim lngCounter As Long

lngCounter = 0
For Each dicItem In Dic1
If Dic2.Exists(dicItem) Then 'Check the key
ReDim Preserve aryMatched(lngCounter)
aryMatched(lngCounter) = dicItem
lngCounter = lngCounter + 1
End If
Next dicItem

If lngCounter = 0 Then
MatchedArray = Empty
Else
MatchedArray = aryMatched
End If
End Function

--
HTH...

Jim Thomlinson


"Bob" wrote:

Columns A & B contain several thousand Project Numbers (e.g., P1052, PA844,
P6721.6, etc.). Column A has the latest list of Project Numbers. Column B
has an older list of Project Numbers. As such, column B is a subset of
column A. I need to find all of the €œnew€ (i.e., unique) Project Numbers
that exist in column A relative to column B, and put the results in column C.
Please note that row 1 is used for column headings, so the data contained in
columns A and B start in row 2.

I would appreciate any help in writing a macro that compares the Project
Numbers in columns A and B and outputs the unique Project Numbers to column C
(starting in row 2). The macro would know to stop when it encounters the
last Project Number in column A (FYI - there are blank cells after the last
Project Number in column A, which obviously is the longest of the two
columns).

Thanks for the help.
Bob

Bob
Finding Unique Entries Among Two Columns
 
Jim,
Thanks a million!!! I sincerely appreciate your help. I don't mean to
sound naive, but I thought that the solution would end up being 10-15 lines
of code. I didn't realize how involved it truly was.
Again, thanks for all your help.
Regards, Bob

"Jim Thomlinson" wrote:

Here is some code that I use (similar to anywayts). You MUST reference the
project to "Microsoft Scripting Runtime" (In the VBE Tools-References...)

Private Sub MatchedAandB()
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 varMatched As Variant 'Array of unmatched items
Dim wksNew As Worksheet
Dim lngCounter As Long

blnValidRanges = True

On Error Resume Next
Set rngRange1 = Intersect(UsedRange, range("A:A"))
Set rngRange2 = Intersect(UsedRange, range("B:B"))
Set Dic1 = CreateDictionary(rngRange1)
Set Dic2 = CreateDictionary(rngRange2)
varMatched = MatchedArray(Dic1, Dic2)
If IsArray(varMatched) Then
Set wksNew = Sheets.Add
With wksNew
.Range("A1").Value = "Matched Items"
Set rngCurrent = .Range("A2")
For lngCounter = LBound(varMatched) To UBound(varMatched)
rngCurrent.Value = varMatched(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter

End With
Else
MsgBox "No Matching Items", vbOKOnly, "No Matches"
End If

End If
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 MatchedArray(ByVal Dic1 As Scripting.Dictionary, _
ByVal Dic2 As Scripting.Dictionary) As Variant
Dim dicItem As Variant
Dim aryMatched() As String
Dim lngCounter As Long

lngCounter = 0
For Each dicItem In Dic1
If Dic2.Exists(dicItem) Then 'Check the key
ReDim Preserve aryMatched(lngCounter)
aryMatched(lngCounter) = dicItem
lngCounter = lngCounter + 1
End If
Next dicItem

If lngCounter = 0 Then
MatchedArray = Empty
Else
MatchedArray = aryMatched
End If
End Function

--
HTH...

Jim Thomlinson


"Bob" wrote:

Columns A & B contain several thousand Project Numbers (e.g., P1052, PA844,
P6721.6, etc.). Column A has the latest list of Project Numbers. Column B
has an older list of Project Numbers. As such, column B is a subset of
column A. I need to find all of the €œnew€ (i.e., unique) Project Numbers
that exist in column A relative to column B, and put the results in column C.
Please note that row 1 is used for column headings, so the data contained in
columns A and B start in row 2.

I would appreciate any help in writing a macro that compares the Project
Numbers in columns A and B and outputs the unique Project Numbers to column C
(starting in row 2). The macro would know to stop when it encounters the
last Project Number in column A (FYI - there are blank cells after the last
Project Number in column A, which obviously is the longest of the two
columns).

Thanks for the help.
Bob

Bob
Finding Unique Entries Among Two Columns
 
Jim,
Please forgive my ignorane (I'm a novice VB programmer), but I copied your
code to a module. I then went to execute it (using Excel's menus: Tools |
Macro | Macros...), but I didn't see anything listed. Could you please tell
me how I run your macro?
Thanks, Bob


"Jim Thomlinson" wrote:

Here is some code that I use (similar to anywayts). You MUST reference the
project to "Microsoft Scripting Runtime" (In the VBE Tools-References...)

Private Sub MatchedAandB()
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 varMatched As Variant 'Array of unmatched items
Dim wksNew As Worksheet
Dim lngCounter As Long

blnValidRanges = True

On Error Resume Next
Set rngRange1 = Intersect(UsedRange, range("A:A"))
Set rngRange2 = Intersect(UsedRange, range("B:B"))
Set Dic1 = CreateDictionary(rngRange1)
Set Dic2 = CreateDictionary(rngRange2)
varMatched = MatchedArray(Dic1, Dic2)
If IsArray(varMatched) Then
Set wksNew = Sheets.Add
With wksNew
.Range("A1").Value = "Matched Items"
Set rngCurrent = .Range("A2")
For lngCounter = LBound(varMatched) To UBound(varMatched)
rngCurrent.Value = varMatched(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter

End With
Else
MsgBox "No Matching Items", vbOKOnly, "No Matches"
End If

End If
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 MatchedArray(ByVal Dic1 As Scripting.Dictionary, _
ByVal Dic2 As Scripting.Dictionary) As Variant
Dim dicItem As Variant
Dim aryMatched() As String
Dim lngCounter As Long

lngCounter = 0
For Each dicItem In Dic1
If Dic2.Exists(dicItem) Then 'Check the key
ReDim Preserve aryMatched(lngCounter)
aryMatched(lngCounter) = dicItem
lngCounter = lngCounter + 1
End If
Next dicItem

If lngCounter = 0 Then
MatchedArray = Empty
Else
MatchedArray = aryMatched
End If
End Function

--
HTH...

Jim Thomlinson


"Bob" wrote:

Columns A & B contain several thousand Project Numbers (e.g., P1052, PA844,
P6721.6, etc.). Column A has the latest list of Project Numbers. Column B
has an older list of Project Numbers. As such, column B is a subset of
column A. I need to find all of the €œnew€ (i.e., unique) Project Numbers
that exist in column A relative to column B, and put the results in column C.
Please note that row 1 is used for column headings, so the data contained in
columns A and B start in row 2.

I would appreciate any help in writing a macro that compares the Project
Numbers in columns A and B and outputs the unique Project Numbers to column C
(starting in row 2). The macro would know to stop when it encounters the
last Project Number in column A (FYI - there are blank cells after the last
Project Number in column A, which obviously is the longest of the two
columns).

Thanks for the help.
Bob

John[_88_]
Finding Unique Entries Among Two Columns
 
Hi Bob,

Change the first line:

"Private Sub MatchedAandB()"
to
"Public Sub MatchedAandB()"

You can look up "Understanding Scope and Visibility" in the VBE help for
details.

Best regards

John

"Bob" wrote in message
...
Jim,
Please forgive my ignorane (I'm a novice VB programmer), but I copied your
code to a module. I then went to execute it (using Excel's menus: Tools |
Macro | Macros...), but I didn't see anything listed. Could you please
tell
me how I run your macro?
Thanks, Bob


"Jim Thomlinson" wrote:

Here is some code that I use (similar to anywayts). You MUST reference
the
project to "Microsoft Scripting Runtime" (In the VBE
Tools-References...)

Private Sub MatchedAandB()
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 varMatched As Variant 'Array of unmatched items
Dim wksNew As Worksheet
Dim lngCounter As Long

blnValidRanges = True

On Error Resume Next
Set rngRange1 = Intersect(UsedRange, range("A:A"))
Set rngRange2 = Intersect(UsedRange, range("B:B"))
Set Dic1 = CreateDictionary(rngRange1)
Set Dic2 = CreateDictionary(rngRange2)
varMatched = MatchedArray(Dic1, Dic2)
If IsArray(varMatched) Then
Set wksNew = Sheets.Add
With wksNew
.Range("A1").Value = "Matched Items"
Set rngCurrent = .Range("A2")
For lngCounter = LBound(varMatched) To UBound(varMatched)
rngCurrent.Value = varMatched(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter

End With
Else
MsgBox "No Matching Items", vbOKOnly, "No Matches"
End If

End If
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 MatchedArray(ByVal Dic1 As Scripting.Dictionary, _
ByVal Dic2 As Scripting.Dictionary) As Variant
Dim dicItem As Variant
Dim aryMatched() As String
Dim lngCounter As Long

lngCounter = 0
For Each dicItem In Dic1
If Dic2.Exists(dicItem) Then 'Check the key
ReDim Preserve aryMatched(lngCounter)
aryMatched(lngCounter) = dicItem
lngCounter = lngCounter + 1
End If
Next dicItem

If lngCounter = 0 Then
MatchedArray = Empty
Else
MatchedArray = aryMatched
End If
End Function

--
HTH...

Jim Thomlinson


"Bob" wrote:

Columns A & B contain several thousand Project Numbers (e.g., P1052,
PA844,
P6721.6, etc.). Column A has the latest list of Project Numbers.
Column B
has an older list of Project Numbers. As such, column B is a subset of
column A. I need to find all of the "new" (i.e., unique) Project
Numbers
that exist in column A relative to column B, and put the results in
column C.
Please note that row 1 is used for column headings, so the data
contained in
columns A and B start in row 2.

I would appreciate any help in writing a macro that compares the
Project
Numbers in columns A and B and outputs the unique Project Numbers to
column C
(starting in row 2). The macro would know to stop when it encounters
the
last Project Number in column A (FYI - there are blank cells after the
last
Project Number in column A, which obviously is the longest of the two
columns).

Thanks for the help.
Bob

Bob
Finding Unique Entries Among Two Columns
 
John,
When I change the first line to "Public" and then run the macro, I get the
following error message:

Compile error:
Sub or Function not defined

VBE then highlights "CreateDictionary" in the line:

Set Dic1 = CreateDictionary(rngRange1)

Bob


"John" wrote:

Hi Bob,

Change the first line:

"Private Sub MatchedAandB()"
to
"Public Sub MatchedAandB()"

You can look up "Understanding Scope and Visibility" in the VBE help for
details.

Best regards

John

"Bob" wrote in message
...
Jim,
Please forgive my ignorane (I'm a novice VB programmer), but I copied your
code to a module. I then went to execute it (using Excel's menus: Tools |
Macro | Macros...), but I didn't see anything listed. Could you please
tell
me how I run your macro?
Thanks, Bob


"Jim Thomlinson" wrote:

Here is some code that I use (similar to anywayts). You MUST reference
the
project to "Microsoft Scripting Runtime" (In the VBE
Tools-References...)

Private Sub MatchedAandB()
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 varMatched As Variant 'Array of unmatched items
Dim wksNew As Worksheet
Dim lngCounter As Long

blnValidRanges = True

On Error Resume Next
Set rngRange1 = Intersect(UsedRange, range("A:A"))
Set rngRange2 = Intersect(UsedRange, range("B:B"))
Set Dic1 = CreateDictionary(rngRange1)
Set Dic2 = CreateDictionary(rngRange2)
varMatched = MatchedArray(Dic1, Dic2)
If IsArray(varMatched) Then
Set wksNew = Sheets.Add
With wksNew
.Range("A1").Value = "Matched Items"
Set rngCurrent = .Range("A2")
For lngCounter = LBound(varMatched) To UBound(varMatched)
rngCurrent.Value = varMatched(lngCounter)
Set rngCurrent = rngCurrent.Offset(1, 0)
Next lngCounter

End With
Else
MsgBox "No Matching Items", vbOKOnly, "No Matches"
End If

End If
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 MatchedArray(ByVal Dic1 As Scripting.Dictionary, _
ByVal Dic2 As Scripting.Dictionary) As Variant
Dim dicItem As Variant
Dim aryMatched() As String
Dim lngCounter As Long

lngCounter = 0
For Each dicItem In Dic1
If Dic2.Exists(dicItem) Then 'Check the key
ReDim Preserve aryMatched(lngCounter)
aryMatched(lngCounter) = dicItem
lngCounter = lngCounter + 1
End If
Next dicItem

If lngCounter = 0 Then
MatchedArray = Empty
Else
MatchedArray = aryMatched
End If
End Function

--
HTH...

Jim Thomlinson


"Bob" wrote:

Columns A & B contain several thousand Project Numbers (e.g., P1052,
PA844,
P6721.6, etc.). Column A has the latest list of Project Numbers.
Column B
has an older list of Project Numbers. As such, column B is a subset of
column A. I need to find all of the "new" (i.e., unique) Project
Numbers
that exist in column A relative to column B, and put the results in
column C.
Please note that row 1 is used for column headings, so the data
contained in
columns A and B start in row 2.

I would appreciate any help in writing a macro that compares the
Project
Numbers in columns A and B and outputs the unique Project Numbers to
column C
(starting in row 2). The macro would know to stop when it encounters
the
last Project Number in column A (FYI - there are blank cells after the
last
Project Number in column A, which obviously is the longest of the two
columns).

Thanks for the help.
Bob


All times are GMT +1. The time now is 11:13 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com