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.
 
Sort by date Sort by votes
I'm glad you posted a copy of the workbook as we would never have gotten a solution without as you were not letting us know key pieces of information such as your reference to the code name of the sheets not what actual tab name the user sees and the ID was in Col. A and Col B. not only Col. A.

In any case this should do the job (it did for me):

Code: 
Option Explicit
Sub Macro1()

    Dim xlnCalcMethod As XlCalculation
    Dim wsMySheet As Worksheet
    Dim wsSource As Worksheet
    Dim wsChildSheet1 As Worksheet
    Dim wsChildSheet2 As Worksheet
    Dim wsOutput As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim lngPasteRow As Long
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    For Each wsMySheet In ThisWorkbook.Sheets
        If wsMySheet.CodeName = "Sheet1" Then 'Code tab name for 'Late In Summary'
            Set wsSource = wsMySheet
        ElseIf wsMySheet.CodeName = "Sheet2" Then 'Code tab name for 'Hub Absence Report'
            Set wsChildSheet1 = wsMySheet
        ElseIf wsMySheet.CodeName = "Sheet6" Then 'Code tab name for 'Time Off Request'
            Set wsChildSheet2 = wsMySheet
        ElseIf wsMySheet.CodeName = "Sheet4" Then 'Code tab name for 'Report'
            Set wsOutput = wsMySheet
        End If
    Next wsMySheet
    
    With wsSource
        lngLastRow = .Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For lngMyRow = 2 To lngLastRow
            If Evaluate("COUNTIF('" & wsChildSheet1.Name & "'!A:A,'" & wsSource.Name & "'!B" & lngMyRow & ")+COUNTIF('" & wsChildSheet2.Name & "'!F:F,'" & wsSource.Name & "'!B" & lngMyRow & ")") >= 1 Then
                On Error Resume Next 'Ignore error if there's no data on the 'wsOutput' sheet
                    lngPasteRow = wsOutput.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lngPasteRow = lngPasteRow + 1
                On Error GoTo 0
                .Rows(lngMyRow).EntireRow.Copy Destination:=wsOutput.Rows(lngPasteRow).EntireRow
            End If
        Next lngMyRow
    End With
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Trebor76 said:
I'm glad you posted a copy of the workbook as we would never have gotten a solution without as you were not letting us know key pieces of information such as your reference to the code name of the sheets not what actual tab name the user sees and the ID was in Col. A and Col B. not only Col. A.

In any case this should do the job (it did for me):

Code: 
Option Explicit
Sub Macro1()

    Dim xlnCalcMethod As XlCalculation
    Dim wsMySheet As Worksheet
    Dim wsSource As Worksheet
    Dim wsChildSheet1 As Worksheet
    Dim wsChildSheet2 As Worksheet
    Dim wsOutput As Worksheet
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim lngPasteRow As Long
    
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    For Each wsMySheet In ThisWorkbook.Sheets
        If wsMySheet.CodeName = "Sheet1" Then 'Code tab name for 'Late In Summary'
            Set wsSource = wsMySheet
        ElseIf wsMySheet.CodeName = "Sheet2" Then 'Code tab name for 'Hub Absence Report'
            Set wsChildSheet1 = wsMySheet
        ElseIf wsMySheet.CodeName = "Sheet6" Then 'Code tab name for 'Time Off Request'
            Set wsChildSheet2 = wsMySheet
        ElseIf wsMySheet.CodeName = "Sheet4" Then 'Code tab name for 'Report'
            Set wsOutput = wsMySheet
        End If
    Next wsMySheet
    
    With wsSource
        lngLastRow = .Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For lngMyRow = 2 To lngLastRow
            If Evaluate("COUNTIF('" & wsChildSheet1.Name & "'!A:A,'" & wsSource.Name & "'!B" & lngMyRow & ")+COUNTIF('" & wsChildSheet2.Name & "'!F:F,'" & wsSource.Name & "'!B" & lngMyRow & ")") >= 1 Then
                On Error Resume Next 'Ignore error if there's no data on the 'wsOutput' sheet
                    lngPasteRow = wsOutput.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lngPasteRow = lngPasteRow + 1
                On Error GoTo 0
                .Rows(lngMyRow).EntireRow.Copy Destination:=wsOutput.Rows(lngPasteRow).EntireRow
            End If
        Next lngMyRow
    End With
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

End Sub

Regards,

Robert
Click to expand...

Did I ever tell you that you are amazing!!! I just changed the ">=" to just "<" to get the non duplicates over to the "Report" sheet. So much faster than my old codes lol. You rock!:)
 
Upvote 0
NP. Glad we got it sorted in the end. Thanks for the like :)
 
Upvote 0
Trebor76 said:
NP. Glad we got it sorted in the end. Thanks for the like :)
Click to expand...

Last question I swear lol. How do I get the rows to start on Row 2 of the "Report" worksheet because it's showing up on row 1. I can simply do a VBA to insert row and headers but If I can somehow add that to the existing code that would save me from doing a ton more codes lol.
 
Last edited:
Upvote 0
Try this in the appropriate section of my last macro:

Rich (BB code): 
On Error Resume Next 'Ignore error if there's no data on the 'wsOutput' sheet
    lngPasteRow = wsOutput.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If lngPasteRow = 0 Then
        lngPasteRow = 2 'Default row number if there's no data on the 'wsOutput' sheet. Change to suit if necessary.
    Else
        lngPasteRow = lngPasteRow + 1
    End If
On Error GoTo 0

Note I would change change the flag to identify unique entries to this...

Rich (BB code): 
If Evaluate("COUNTIF('" & wsChildSheet1.Name & "'!A:A,'" & wsSource.Name & "'!B" & lngMyRow & ")+COUNTIF('" & wsChildSheet2.Name & "'!F:F,'" & wsSource.Name & "'!B" & lngMyRow & ")")  = 0 Then

...as I feel it makes more sense. Having < 1 as you have done will work too.

Thanks,

Robert
 
Last edited:
Upvote 0
jluangrath88 said:
Last question I swear lol. How do I get the rows to start on Row 2 of the "Report" worksheet because it's showing up on row 1. I can simply do a VBA to insert row and headers but If I can somehow add that to the existing code that would save me from doing a ton more codes lol.
Click to expand...

Never mind I figured it out lol.
 
Upvote 0
Trebor76 said:
Try this in the appropriate section of my last macro:

Code: 
On Error Resume Next 'Ignore error if there's no data on the 'wsOutput' sheet
    lngPasteRow = wsOutput.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If lngPasteRow = 0 Then
        lngPasteRow = 2 'Default row number if there's no data on the 'wsOutput' sheet. Change to suit if necessary.
    Else
        lngPasteRow = lngPasteRow + 1
    End If
On Error GoTo 0

Note I would change change the flag to identify unique entries to this...

Code: 
If Evaluate("COUNTIF('" & wsChildSheet1.Name & "'!A:A,'" & wsSource.Name & "'!B" & lngMyRow & ")+COUNTIF('" & wsChildSheet2.Name & "'!F:F,'" & wsSource.Name & "'!B" & lngMyRow & ")") [B] = 0[/B] Then

...as [I]I[/I] feel it makes more sense. Having < 1 as you have done will work too.

Thanks,

Robert[/QUOTE]


Thank you I will give this a try too. :)
Click to expand...
 
Upvote 0
Trebor76 said:
Try this in the appropriate section of my last macro:

Code: 
On Error Resume Next 'Ignore error if there's no data on the 'wsOutput' sheet
    lngPasteRow = wsOutput.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If lngPasteRow = 0 Then
        lngPasteRow = 2 'Default row number if there's no data on the 'wsOutput' sheet. Change to suit if necessary.
    Else
        lngPasteRow = lngPasteRow + 1
    End If
On Error GoTo 0

Note I would change change the flag to identify unique entries to this...

Code: 
If Evaluate("COUNTIF('" & wsChildSheet1.Name & "'!A:A,'" & wsSource.Name & "'!B" & lngMyRow & ")+COUNTIF('" & wsChildSheet2.Name & "'!F:F,'" & wsSource.Name & "'!B" & lngMyRow & ")") [B] = 0[/B] Then

...as [I]I[/I] feel it makes more sense. Having < 1 as you have done will work too.

Thanks,

Robert[/QUOTE]

Perfect!!! Worked like a charm. Thanks so much.
Click to expand...
 
Upvote 0
Hello Mam,

Has your problem been solved of subjected query, if yes please provide me the solution of the same as i am also seeking its solution since so long,

additionaly is there any formulae to get the desired result instead of using vba code??

Thanks
Deepak
 
Last edited by a moderator:
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
766
MARK858
MARK858
H
  • Question
comparing values in a column against multiple sheets and returning subsequent values from other columns
Replies
1
Views
885
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,350
Messages
6,124,430
Members
449,158
Latest member
burk0007

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