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

[jluangrath88]

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:
[TABLE="width: 128"]
<colgroup><col span="2"></colgroup><tbody>[TR]
[TD="align: center"]101010
[/TD]
[TD="align: center"] XXXX
[/TD]
[/TR]
[TR]
[TD="align: center"] 202020
[/TD]
[TD="align: center"] AAAA
[/TD]
[/TR]
[TR]
[TD="align: center"]212121
[/TD]
[TD="align: center"] BBBB
[/TD]
[/TR]
[TR]
[TD="align: center"]414141[/TD]
[TD="align: center"]ABAB
[/TD]
[/TR]
[TR]
[TD="align: center"]616161[/TD]
[TD="align: center"]XOXO
[/TD]
[/TR]
[TR]
[TD="align: center"]606060
[/TD]
[TD="align: center"]JAJA
[/TD]
[/TR]
</tbody>[/TABLE]

Sheet2 Contains:
[TABLE="width: 128"]
<colgroup><col span="2"></colgroup><tbody>[TR]
[TD]101010[/TD]
[TD]XXXX[/TD]
[/TR]
[TR]
[TD]414141[/TD]
[TD]ABAB[/TD]
[/TR]
[TR]
[TD]616161[/TD]
[TD]XOXO
[/TD]
[/TR]
[TR]
[TD]80808
[/TD]
[TD]LOLO[/TD]
[/TR]
[TR]
[TD]909090[/TD]
[TD]RERE
[/TD]
[/TR]
</tbody>[/TABLE]

Sheet3:
[TABLE="width: 128"]
<colgroup><col span="2"></colgroup><tbody>[TR]
[TD]909090[/TD]
[TD]CICI[/TD]
[/TR]
[TR]
[TD]101010[/TD]
[TD]XXXX[/TD]
[/TR]
[TR]
[TD]212121[/TD]
[TD]BBBB[/TD]
[/TR]
[TR]
[TD]676767
[/TD]
[TD]GGGG
[/TD]
[/TR]
</tbody>[/TABLE]


The unique values between those three sheets would then be:
[TABLE="width: 128"]
<colgroup><col span="2" width="64"></colgroup><tbody>[TR]
[TD="class: xl65, width: 64"]202020[/TD]
[TD="class: xl65, width: 64"]AAAA[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 128"]
<colgroup><col span="2" width="64"></colgroup><tbody>[TR]
[TD="class: xl65, width: 64"]606060[/TD]
[TD="class: xl65, width: 64"]JAJA
[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 128"]
<colgroup><col span="2" width="64"></colgroup><tbody>[TR]
[TD="class: xl65, width: 64"]80808[/TD]
[TD="class: xl65, width: 64"]LOLO[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 128"]
<colgroup><col span="2" width="64"></colgroup><tbody>[TR]
[TD="class: xl65, width: 64"]676767[/TD]
[TD="class: xl65, width: 64"]GGGG
[/TD]
[/TR]
</tbody>[/TABLE]

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.

 

[MickG]

Try this:-
NB:- The data in each sheet is assumed to start "A2".

[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

 

[jluangrath88]

Try this:-
NB:- The data in each sheet is assumed to start "A2".

[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

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).

 

[Trebor76]

Hi jluangrath88,

Try this:

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

 

[jluangrath88]

Hi jluangrath88,

Try this:

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

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."

 

[Trebor76]

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

That's odd - it worked for me

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.

 

[jluangrath88]

That's odd - it worked for me

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.

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.

 

[MickG]

Try this:-

[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

 

[Trebor76]

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.

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.

 

[jluangrath88]

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.

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