VBA to Extract Unique Values/Rows Across Multiple Sheets into One Sheet

jluangrath88

jluangrath88

New Member
Joined
Apr 22, 2018
Messages
23
Hi Experts!

Here's my current situation. And I would very much appreciate the help :)

I have 4 different worksheets. Let's call them: Sheet1, Sheet2, Sheet3, and Sheet4. The first 3 contains data that is delivered daily. Sheet4 is meant to dump the raw and compiled data between the first three. These first three sheets have rows that will contain some sort of duplicate value amongst them. I'm trying to extract values and its rows that do not have duplicates amongst the other sheets into one sheet (Sheet4).

For example (unique values underlined):
Sheet1 Contains:
101010
 XXXX
202020
AAAA
212121
 BBBB
414141ABAB
616161XOXO
606060
JAJA

<colgroup><col span="2"></colgroup><tbody>
</tbody>

Sheet2 Contains:
101010XXXX
414141ABAB
616161XOXO
80808
LOLO
909090RERE

<colgroup><col span="2"></colgroup><tbody>
</tbody>

Sheet3:
909090CICI
101010XXXX
212121BBBB
676767
GGGG

<colgroup><col span="2"></colgroup><tbody>
</tbody>


The unique values between those three sheets would then be:
202020AAAA

<colgroup><col span="2" width="64"></colgroup><tbody>
</tbody>

606060JAJA

<colgroup><col span="2" width="64"></colgroup><tbody>
</tbody>

80808LOLO

<colgroup><col span="2" width="64"></colgroup><tbody>
</tbody>

676767GGGG

<colgroup><col span="2" width="64"></colgroup><tbody>
</tbody>

The unique values between those three sheets need to be extracted to Sheet4.

I have the VBA code to remove duplicates from one sheet to the next. But I've been having to run the code twice as to make sure I cover all three sheets. However the multiple macros is making my workbook slow. So I'm wondering if there's a faster way I can do this with one code for all sheets. And then have those unique values compiled/copied/pasted into one specific worksheet.
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
Try this:-
NB:- The data in each sheet is assumed to start "A2".
Code: 
[COLOR="Navy"]Sub[/COLOR] MG28Apr19
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Shts [COLOR="Navy"]As[/COLOR] Variant, Sht [COLOR="Navy"]As[/COLOR] Variant, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Shts = Array("Sheet1", "Sheet2", "Sheet3")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Sht [COLOR="Navy"]In[/COLOR] Shts
    [COLOR="Navy"]With[/COLOR] Sheets(Sht)
         [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        Txt = Dn.Value & ", " & Dn.Offset(, 1).Value
            [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
                 .Add Txt, 1
            [COLOR="Navy"]Else[/COLOR]
                .Item(Txt) = .Item(Txt) + 1
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] Sht
 
 
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 ReDim ray(1 To .Count, 1 To 2)
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] .Item(K) = 1 [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        ray(c, 1) = Split(K, ", ")(0)
        ray(c, 2) = Split(K, ", ")(1)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
 Sheets("Sheet4").Range("A2").Resize(c, 2).Value = ray
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG said:
Try this:-
NB:- The data in each sheet is assumed to start "A2".
Code: 
[COLOR=Navy]Sub[/COLOR] MG28Apr19
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Shts [COLOR=Navy]As[/COLOR] Variant, Sht [COLOR=Navy]As[/COLOR] Variant, Txt [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Shts = Array("Sheet1", "Sheet2", "Sheet3")
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Sht [COLOR=Navy]In[/COLOR] Shts
    [COLOR=Navy]With[/COLOR] Sheets(Sht)
         [COLOR=Navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    [COLOR=Navy]End[/COLOR] With
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        Txt = Dn.Value & ", " & Dn.Offset(, 1).Value
            [COLOR=Navy]If[/COLOR] Not .Exists(Txt) [COLOR=Navy]Then[/COLOR]
                 .Add Txt, 1
            [COLOR=Navy]Else[/COLOR]
                .Item(Txt) = .Item(Txt) + 1
            [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]Next[/COLOR] Sht
 
 
[COLOR=Navy]Dim[/COLOR] K [COLOR=Navy]As[/COLOR] Variant, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
 ReDim ray(1 To .Count, 1 To 2)
 [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] .keys
    [COLOR=Navy]If[/COLOR] .Item(K) = 1 [COLOR=Navy]Then[/COLOR]
        c = c + 1
        ray(c, 1) = Split(K, ", ")(0)
        ray(c, 2) = Split(K, ", ")(1)
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] K
 Sheets("Sheet4").Range("A2").Resize(c, 2).Value = ray
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...
It didn't work.

It just pulled different wording from each sheet.

I guess I need to be more specific. For instance if Column A in Sheet1 has the numerical value of 202020, and it is completely unique (i.e the other sheets don't contain it). I need the VBA code to extract the whole entire row that the particular unique value is in. So whatever is in that same row with that unique value needs to be pulled over as well.

I've accomplished this with these two codes below:

Sub RemoveDupsBetweenListsTimeOFF()

Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim C1row As Long
Dim C2row As Long
Dim C2TotalRows As Long
Dim PersonID As String
Dim NoDups As Long

Set sht1 = Worksheets("Late In Summary")
Set sht2 = Worksheets("Time Off Request")
sht2.Activate
C2TotalRows = Application.CountA(Range("A:A"))
C1row = 2

Do While sht1.Cells(C1row, 2).Value <> ""

CustID = sht1.Cells(C1row, 2).Value

For C2row = 2 To C2TotalRows

If CustID = Cells(C2row, 6).Value Then

sht1.Activate
Rows(C1row).Delete
NoDups = NoDups + 1
C1row = C1row - 1
sht2.Activate
Exit For

End If

Next

C1row = C1row + 1

Loop
Worksheets("Late In Summary").Range("A:J").Columns.AutoFit
MsgBox NoDups & " Duplicated from 'PTO Submission REMOVED' list"

End Sub

Sub RemoveDupsBetweenListsHubAbsence()

Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim C1row As Long
Dim C2row As Long
Dim C2TotalRows As Long
Dim PersonID As String
Dim NoDups As Long

Set sht1 = Worksheets("Late In Summary")
Set sht2 = Worksheets("Hub Absence Report")
sht2.Activate
C2TotalRows = Application.CountA(Range("A:A"))
C1row = 2

Do While sht1.Cells(C1row, 2).Value <> ""

CustID = sht1.Cells(C1row, 2).Value

For C2row = 2 To C2TotalRows

If CustID = Cells(C2row, 1).Value Then

sht1.Activate
Rows(C1row).Delete
NoDups = NoDups + 1
C1row = C1row - 1
sht2.Activate
Exit For

End If

Next

C1row = C1row + 1

Loop
Worksheets("Late In Summary").Range("A:J").Columns.AutoFit
MsgBox NoDups & " Duplicated from 'Hub Absence Report' list REMOVED"

End Sub

But like I said, doing two separate codes and assigning them to the activeX button is making my workbook super slow. I want to make it into one simple macro and have the results compiled into a separate sheet (Sheet4).
 
Last edited:
Upvote 0
Hi jluangrath88,

Try this:

Code: 
Option Explicit
Sub Macro1()
    
    Dim xlnCalcMethod As XlCalculation
    Dim varMySheet As Variant
    Dim varTotalArray() As Variant
    Dim lngTotalArrayCount As Long
    Dim varArrayElement As Variant
    Dim lngItemCount As Long
    Dim lngMyRow As Long
    Dim strCopyInfo() As String
    Dim lngPasteRow As Long
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    'Create a full array of entries from Col. A plus sheet name plus row number (separated by a pipe character) of each 'varMySheet' worksheet
    For Each varMySheet In Array("Late In Summary", "Hub Absence Report") 'Sheets containing data. Change to suit.
        For lngMyRow = 2 To Sheets(CStr(varMySheet)).Cells(Rows.Count, "A").End(xlUp).Row 'Works from Row 2 down to the last Row in Col. A. Change to suit.
            If Len(Sheets(CStr(varMySheet)).Range("A" & lngMyRow)) > 0 Then
                lngTotalArrayCount = lngTotalArrayCount + 1
                ReDim Preserve varTotalArray(1 To lngTotalArrayCount) 'Append the current record to the existing array
                varTotalArray(lngTotalArrayCount) = Sheets(CStr(varMySheet)).Range("A" & lngMyRow) & "|" & CStr(varMySheet) & "|" & lngMyRow
            End If
        Next lngMyRow
    Next varMySheet
    
    'Loop through each item in the full (total) array
    For lngTotalArrayCount = LBound(varTotalArray) To UBound(varTotalArray)
        lngItemCount = 0
        For Each varArrayElement In varTotalArray
            If Left(varArrayElement, Application.Search("|", varArrayElement) - 1) = Left(varTotalArray(lngTotalArrayCount), Application.Search("|", varArrayElement) - 1) Then
                lngItemCount = lngItemCount + 1
            End If
        Next varArrayElement
        'If text from Col. A in the full (total) array only appears once, then
        If lngItemCount = 1 Then
            '...copy that row into the next avaliable row of Sheet4 (change to suit).
            lngPasteRow = Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Row + 1
            strCopyInfo = Split(varTotalArray(lngTotalArrayCount), "|")
            Sheets(CStr(strCopyInfo(1))).Rows(CLng(strCopyInfo(2))).EntireRow.Copy Destination:=Sheets("Sheet4").Rows(lngPasteRow).EntireRow 'Change output to Sheet4 here
        End If
    Next lngTotalArrayCount
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With
    
End Sub

Regards,

Robert
 
Upvote 0
Trebor76 said:
Hi jluangrath88,

Try this:

Code: 
Option Explicit
Sub Macro1()
    
    Dim xlnCalcMethod As XlCalculation
    Dim varMySheet As Variant
    Dim varTotalArray() As Variant
    Dim lngTotalArrayCount As Long
    Dim varArrayElement As Variant
    Dim lngItemCount As Long
    Dim lngMyRow As Long
    Dim strCopyInfo() As String
    Dim lngPasteRow As Long
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    'Create a full array of entries from Col. A plus sheet name plus row number (separated by a pipe character) of each 'varMySheet' worksheet
    For Each varMySheet In Array("Late In Summary", "Hub Absence Report") 'Sheets containing data. Change to suit.
        For lngMyRow = 2 To Sheets(CStr(varMySheet)).Cells(Rows.Count, "A").End(xlUp).Row 'Works from Row 2 down to the last Row in Col. A. Change to suit.
            If Len(Sheets(CStr(varMySheet)).Range("A" & lngMyRow)) > 0 Then
                lngTotalArrayCount = lngTotalArrayCount + 1
                ReDim Preserve varTotalArray(1 To lngTotalArrayCount) 'Append the current record to the existing array
                varTotalArray(lngTotalArrayCount) = Sheets(CStr(varMySheet)).Range("A" & lngMyRow) & "|" & CStr(varMySheet) & "|" & lngMyRow
            End If
        Next lngMyRow
    Next varMySheet
    
    'Loop through each item in the full (total) array
    For lngTotalArrayCount = LBound(varTotalArray) To UBound(varTotalArray)
        lngItemCount = 0
        For Each varArrayElement In varTotalArray
            If Left(varArrayElement, Application.Search("|", varArrayElement) - 1) = Left(varTotalArray(lngTotalArrayCount), Application.Search("|", varArrayElement) - 1) Then
                lngItemCount = lngItemCount + 1
            End If
        Next varArrayElement
        'If text from Col. A in the full (total) array only appears once, then
        If lngItemCount = 1 Then
            '...copy that row into the next avaliable row of Sheet4 (change to suit).
            lngPasteRow = Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Row + 1
            strCopyInfo = Split(varTotalArray(lngTotalArrayCount), "|")
            Sheets(CStr(strCopyInfo(1))).Rows(CLng(strCopyInfo(2))).EntireRow.Copy Destination:=Sheets("Sheet4").Rows(lngPasteRow).EntireRow 'Change output to Sheet4 here
        End If
    Next lngTotalArrayCount
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With
    
End Sub

Regards,

Robert
Click to expand...

It's not working either. It's still pulling duplicates onto the new sheet.

I need to find a way to combine the two codes I already have in my second post into one macro and have the results pasted over to another sheet, a fourth one "Lets call it Sheet4". In the two codes I have, it effectively removes the duplicates(and its entire row) from all three sheets. However it doesn't consolidate the results into a new sheet, it just removes Dups between Sheet1 "Late in Summary," Sheet2 "Hub Absence Report," Sheet3 "Time Off Requests"... and leave the remaining results on Sheet1 "Late In Summary."
 
Upvote 0
It's not working either. It's still pulling duplicates onto the new sheet.
Click to expand...

That's odd - it worked for me :confused:

Was Sheet4 cleared of any existing data? If the records were there from a previous run they would then be duplicated the next time you run the macro. Beyond that I'm not sure I'm afraid.
 
Upvote 0
Trebor76 said:
That's odd - it worked for me :confused:

Was Sheet4 cleared of any existing data? If the records were there from a previous run they would then be duplicated the next time you run the macro. Beyond that I'm not sure I'm afraid.
Click to expand...
Yes Sheet4 was completely cleared. I think what went wrong was I just gave you a sample data lol. To be more clear, the other cells in each row contains different values from the other sheets. But I was trying to reference a specific column, lets call it Column A, which has numerical values. So if Column A values in sheet1 is not a duplicate of values in column A of sheet2 or sheet3, I wanted to extract the entire row in sheet1 to sheet4... if that makes any sense at all lol.
 
Last edited:
Upvote 0
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG29Apr41
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, Shts [COLOR=navy]As[/COLOR] Variant, Sht [COLOR=navy]As[/COLOR] Variant, Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Lst [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Shts = Array("Sheet1", "Sheet2", "Sheet3")
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Sht [COLOR=navy]In[/COLOR] Shts
    [COLOR=navy]With[/COLOR] Sheets(Sht)
         [COLOR=navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    [COLOR=navy]End[/COLOR] With
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
       [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
                 .Add Dn.Value, Array(Dn, 1)
            [COLOR=navy]Else[/COLOR]
                Q = .Item(Dn.Value)
                Q(1) = Q(1) + 1
                .Item(Dn.Value) = Q
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Next[/COLOR] Sht
 
 
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
 ReDim ray(1 To .Count, 1 To 1)
 [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
   [COLOR=navy]If[/COLOR] .Item(K)(1) = 1 [COLOR=navy]Then[/COLOR]
        c = c + 1
        Lst = Sheets(.Item(K)(0).Parent.Name).Cells(.Item(K)(0).Row, Columns.Count).End(xlToLeft).Column
        [COLOR=navy]If[/COLOR] Lst > UBound(ray, 2) [COLOR=navy]Then[/COLOR] ReDim Preserve ray(1 To .Count, 1 To Lst)
                [COLOR=navy]For[/COLOR] Ac = 1 To Lst
                    ray(c, Ac) = .Item(K)(0).Offset(, Ac - 1)
                [COLOR=navy]Next[/COLOR] Ac
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] K
 Sheets("Sheet4").Range("A2").Resize(c, UBound(ray, 2)).Value = ray
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
So if Column A values in sheet1 is not a duplicate of values in column A of sheet2 or sheet3, I wanted to extract the entire row in sheet1 to sheet4... if that makes any sense at all lol.
Click to expand...

It makes perfect sense and it's how I coded the macro. Maybe Mick's latest post will (hopefully) solve the issue. If not if you could share your file (perhaps using a file sharing site like www.box.com) devoid of any sensitive data we'll be better able to provide a solution.
 
Upvote 0
Trebor76 said:
It makes perfect sense and it's how I coded the macro. Maybe Mick's latest post will (hopefully) solve the issue. If not if you could share your file (perhaps using a file sharing site like www.box.com) devoid of any sensitive data we'll be better able to provide a solution.
Click to expand...

Sure. I uploaded it here: http://jmp.sh/v/9PQSDgpzoSl9mZRbDAaD ... Please note that on "Late In Summary" (Sheet1) I have highlighted the rows that should have been moved over to "Report" (Sheet4) because the values in Column B "Person ID/Emp ID" aren't duplicates of values in Column A "Employee ID" in "Hub Absence Report" (Sheet2) and Column F in "Time Off Request" (Sheet3). In this case "Person ID" and "Employee ID" are actually the same thing, it's just that the different reports sent to me daily uses different terminology.

But anyhow, the highlighted rows are the ones I need copied and pasted over. If you guys can help that would be great. If not, that's fine. The Dups removal formulas I have works I just hate having too many codes into the worksheet and using a call button for so many as it makes the macro run slow.

Essentially what I need is values i
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
VBA code to extract unique data across multiple sheets and multiple columns
Replies
1
Views
3K
mereslav
M
W
  • Question
Copy sheet with same row values to another sheet
Replies
2
Views
760
MARK858
MARK858
H
  • Question
comparing values in a column against multiple sheets and returning subsequent values from other columns
Replies
1
Views
880
DanteAmor
DanteAmor
E
  • Question
Only unique values to a combobox from multiple columns, vba
2
Replies
10
Views
2K
Akuini
Akuini
L
  • Question
VBA - copy new rows from different sheet, if condition is met
Replies
4
Views
2K
lotrev
L

Forum statistics

Threads
1,215,151
Messages
6,123,316
Members
449,094
Latest member
Chestertim

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