VBA to compare columns on separate sheets for unique value and then extract row content of the unique value

A

Argh_Work

New Member
Joined
Oct 17, 2023
Messages
7
Office Version
  1. 2013
Platform
  1. Windows
Hi All,

I'm self taught and have some pretty big knowledge gaps.
I'd like to compare the Column A in my "Master" worksheet with Column A in my "Compare" worksheet.
If a number is unique to Column A in my "Compare" worksheet I'd like to extract the information from the row and enter it into my result worksheet.

I have figured out how to get the unique value from the column in "Compare" into my "result" worksheet but I can't figure out how to get the entire row copied across.

In the screenshot below I've highlighted in yellow an example of the information that I would like to come across.

I've spent serious time traipsing around the internet looking for a solution to this one but haven't had any luck.
I'd really appreciate help.
1697518773634.png


1697519058172.png


1697519086614.png
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Sort by date Sort by votes
I hope this will work for you:
VBA Code: 
Sub test()
  Dim compareRange As Variant, masterRange As Variant, lRow As Long, i As Long
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")
  
  
  With Worksheets("Master")
  masterRange = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  For i = 1 To UBound(masterRange, 1)
    If Not dict.Exists(masterRange(i, 1)) Then
      dict.Add masterRange(i, 1), 1
    End If
  Next
  
  compareRange = Worksheets("Compare").UsedRange
  With Worksheets("Result")
  For i = 1 To UBound(compareRange, 1)
    If Not dict.Exists(compareRange(i, 1)) Then
      .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row).Offset(1).Resize(, UBound(compareRange, 2)).Value = Application.Index(compareRange, i, 0)
    End If
  Next
  End With
End Sub
 
Upvote 1
Flashbond said:
Sub test() Dim compareRange As Variant, masterRange As Variant, lRow As Long, i As Long Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") With Worksheets("Master") masterRange = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row) End With For i = 1 To UBound(masterRange, 1) If Not dict.Exists(masterRange(i, 1)) Then dict.Add masterRange(i, 1), 1 End If Next compareRange = Worksheets("Compare").UsedRange With Worksheets("Result") For i = 1 To UBound(compareRange, 1) If Not dict.Exists(compareRange(i, 1)) Then .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row).Offset(1).Resize(, UBound(compareRange, 2)).Value = Application.Index(compareRange, i, 0) End If Next End With End Sub
Click to expand...
Thank you so much that is amazing. I really appreciate your work. You have just made my life soooo much easier!
 
Upvote 0
Hi @Flashbond - very helpful. Thank you here!

Just a quick one - I've tried this for comparing sheets with over 20k rows and 15 columns and it seems rather slow. Any thoughts?

Much appreciated
 
Upvote 0
How about this:
VBA Code: 
Sub test()
  Dim compareRange As Variant, masterRange As Variant, lRow As Long, i As Long, j As Long
  Dim tempRange As Variant
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Master")
  masterRange = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  For i = 1 To UBound(masterRange, 1)
    If Not dict.Exists(masterRange(i, 1)) Then
      dict.Add masterRange(i, 1), 1
    End If
  Next
 
  compareRange = Worksheets("Compare").UsedRange
  With Worksheets("Result")
  Redim tempRange(1 To Ubound(compareRange, 2), 1 To 1)
  For i = 1 To UBound(compareRange, 1)
    If Not dict.Exists(compareRange(i, 1)) Then
      For j = 1 to Ubound(compareRange, 2)
        tempRange(j, Ubound(tempRange, 2)) = compareRange(i, j)
        Redim Preserve tempRange(1 To Ubound(tempRange, 1), 1 To Ubound(tempRange, 2)+1)
      Next
    End If
  Next
  Redim Preserve tempRange( 1 To Ubound(tempRange, 1), 1 To Ubound(tempRange, 2)-1)
  .Range("A3").Resize(Ubound(tempRange, 2), Ubound(tempRange, 1)).Value = Application.Transpose(tempRange)
  End With
End Sub
This should be slightly faster. I wrote it without testing. Let me know if you have any issues.
 
Last edited by a moderator:
Upvote 1
Flashbond said:
How about this:
VBA Code: 
Sub test()
  Dim compareRange As Variant, masterRange As Variant, lRow As Long, i As Long, j As Long
  Dim tempRange As Variant
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Master")
  masterRange = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  For i = 1 To UBound(masterRange, 1)
    If Not dict.Exists(masterRange(i, 1)) Then
      dict.Add masterRange(i, 1), 1
    End If
  Next
 
  compareRange = Worksheets("Compare").UsedRange
  With Worksheets("Result")
  Redim tempRange(1 To Ubound(compareRange, 2), 1 To 1)
  For i = 1 To UBound(compareRange, 1)
    If Not dict.Exists(compareRange(i, 1)) Then
      For j = 1 to Ubound(compareRange, 2)
        tempRange(j, Ubound(tempRange, 2)) = compareRange(i, j)
        Redim Preserve tempRange(1 To Ubound(tempRange, 1), 1 To Ubound(tempRange, 2)+1)
      Next
    End If
  Next
  Redim Preserve tempRange( 1 To Ubound(tempRange, 1), 1 To Ubound(tempRange, 2)-1)
  .Range("A3").Resize(Ubound(tempRange, 2), Ubound(tempRange, 1)).Value = Application.Transpose(tempRange)
  End With
End Sub
This should be slightly faster. I wrote it without testing. Let me know if you have any issues.
Click to expand...

Thank again!!

Oddly the above hasn't quite worked. Although the results are pulled through - there is an issue with the way the results are displayed. See below for an example -

Master



Column 1Column 2Column 3Column 4Column 5
1​
QWERTYQWERTYQWERTYQWERTY
2​
QWERTYQWERTYQWERTYQWERTY
3​
QWERTYQWERTYQWERTYQWERTY
4​
QWERTYQWERTYQWERTYQWERTY
5​
QWERTYQWERTYQWERTYQWERTY


Compare



Column 1Column 2Column 3Column 4Column 5
1​
QWERTYQWERTYQWERTYQWERTY
2​
QWERTYQWERTYQWERTYQWERTY
3​
QWERTYQWERTYQWERTYQWERTY
4​
QWERTYQWERTYQWERTYQWERTY
5​
QWERTYQWERTYQWERTYQWERTY
6​
QWERTYQWERTYQWERTYQWERTY
7​
QWERTYQWERTYQWERTYQWERTY
8​
QWERTYQWERTYQWERTYQWERTY
9​
QWERTYQWERTYQWERTYQWERTY
10​
QWERTYQWERTYQWERTYQWERTY




Result


Column 1Column 2Column 3Column 4Column 5
6​
QWERTY
QWERTY
QWERTY
QWERTY
7​
QWERTY
QWERTY
QWERTY
QWERTY
8​
QWERTY
QWERTY
QWERTY
QWERTY
9​
QWERTY
QWERTY
QWERTY
QWERTY
10​
QWERTY
QWERTY
QWERTY
QWERTY
 
Upvote 0
Eh he he hee :) I think I got it with an easy fix:
VBA Code: 
Sub test()
  Dim compareRange As Variant, masterRange As Variant, lRow As Long, i As Long, j As Long
  Dim tempRange As Variant
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Master")
  masterRange = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  For i = 1 To UBound(masterRange, 1)
    If Not dict.Exists(masterRange(i, 1)) Then
      dict.Add masterRange(i, 1), 1
    End If
  Next
 
  compareRange = Worksheets("Compare").UsedRange
  With Worksheets("Result")
  ReDim tempRange(1 To UBound(compareRange, 2), 1 To 1)
  For i = 1 To UBound(compareRange, 1)
    If Not dict.Exists(compareRange(i, 1)) Then
      For j = 1 To UBound(compareRange, 2)
        tempRange(j, UBound(tempRange, 2)) = compareRange(i, j)
      Next
      ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) + 1)
    End If
  Next
  ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) - 1)
  .Range("A3").Resize(UBound(tempRange, 2), UBound(tempRange, 1)).Value = Application.Transpose(tempRange)
  End With
End Sub
 
Last edited by a moderator:
Upvote 1
Solution
Flashbond said:
Eh he he hee :) I think I got it with an easy fix:
VBA Code: 
Sub test()
  Dim compareRange As Variant, masterRange As Variant, lRow As Long, i As Long, j As Long
  Dim tempRange As Variant
  Dim dict As Object
  Set dict = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Master")
  masterRange = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  For i = 1 To UBound(masterRange, 1)
    If Not dict.Exists(masterRange(i, 1)) Then
      dict.Add masterRange(i, 1), 1
    End If
  Next
 
  compareRange = Worksheets("Compare").UsedRange
  With Worksheets("Result")
  ReDim tempRange(1 To UBound(compareRange, 2), 1 To 1)
  For i = 1 To UBound(compareRange, 1)
    If Not dict.Exists(compareRange(i, 1)) Then
      For j = 1 To UBound(compareRange, 2)
        tempRange(j, UBound(tempRange, 2)) = compareRange(i, j)
      Next
      ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) + 1)
    End If
  Next
  ReDim Preserve tempRange(1 To UBound(tempRange, 1), 1 To UBound(tempRange, 2) - 1)
  .Range("A3").Resize(UBound(tempRange, 2), UBound(tempRange, 1)).Value = Application.Transpose(tempRange)
  End With
End Sub
Click to expand...
@Flashbond THANK YOU SO MUCH!
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA to compare values in two columns i.e (Id Number and Dates) on separate sheets for unique values then extract row content to third sheet
Replies
3
Views
486
Legacy 143009
L
R
  • Question
Extract rows based upon unique data in first column of an array
Replies
2
Views
210
RJC40
R
M
  • Solved
VBA Compare two cells (comma separated data) and return unique values
Replies
3
Views
687
Legacy 143009
L
D
  • Question
VBA help to create button that moves to next row after taking screenshot
Replies
1
Views
107
ranman256
ranman256
D
  • Solved
Identify top three maximum unique values in a range using VBA
Replies
2
Views
434
DonEB
D

Forum statistics

Threads
1,215,068
Messages
6,122,950
Members
449,095
Latest member
nmaske

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top