Reaching-Out to VBA Experts ( Identify Duplicates across 2 Sheets and Retun "X" or "Y" ) Please Help

Please_H

Board Regular
Joined
Apr 16, 2017
Messages
181
Office Version
  1. 2019
Platform
  1. Windows
Dear All,

I hope everyone of you are indoors, safe and sound.

Point 01 - What I have :

wip Excel Sheet.xlsm
ABCD
1Dups (X/Y)Bank Cheque No.Value (Dr)Value (Cr)
2986001 500.00 -
3986002 1,000.00 -
4986003 1,500.00 -
5ABC - 300.00
6DEF - 3,000.00
7GHI - 4,500.00
Sheet1


wip Excel Sheet.xlsm
ABCD
1Dups (X/Y)Bank Cheque No.Value (Dr)Value (Cr)
2986010 - 700.00
3986001 - 500.00
4986020 - 950.00
5QRS 8,500.00 -
6ABC 300.00 -
7DEF 3,000.00 -
Sheet2


Point 02 - What I Need :

wip Excel Sheet.xlsm
ABCD
1Dups (X/Y)Bank Cheque No.Value (Dr)Value (Cr)
2X986001 500.00 -
3986002 1,000.00 -
4986003 1,500.00 -
5YABC - 300.00
6YDEF - 3,000.00
7GHI - 4,500.00
Sheet1


wip Excel Sheet.xlsm
ABCD
1Dups (X/Y)Bank Cheque No.Value (Dr)Value (Cr)
2986010 - 700.00
3X986001 - 500.00
4986020 - 950.00
5QRS 8,500.00 -
6YABC 300.00 -
7YDEF 3,000.00 -
Sheet2


Point 03 - What am I trying to do here :

I am trying to find Duplicates across 2 sheets and get a "X" and "Y" in return for what I am looking for :

Point 04 - How do I want to Return "X" ( to understand ; check Green Highlights ) - and Note "X/Y" needs to get returned in both Sheets, so that If I put a SUMIF to them the Value's match.

04.1 - Sheet 1/ Col 'B' & Col 'C' ( vs ) Sheet 2/ Col 'B' & Col 'D'

Point 04 - How do I want to Return "Y" ( to understand ; check Green Highlights ) - and Note "X/Y" needs to get returned in both Sheets, so that If I put a SUMIF to them the Value's match.

04.2 - Sheet 1/ Col 'D' ( vs ) Sheet 2/ Col 'C'


One of the Well-known Members in here, "JLGWhiz" wrote the below coding for me to find duplicates between 2 Sheets.

VBA Code:
Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
    With sh1
        For Each c In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
            Set fn = sh2.Range("B:B").Find(c.Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    adr = fn.Address
                    Do
                        If c.Offset(, 1).Value = fn.Offset(, 2).Value Then
                            c.Offset(, -1) = "X"
                            fn.Offset(, -1) = "X"
                            Exit Do
                        End If
                        Set fn = sh2.Range("B:B").FindNext(fn)
                    Loop While fn.Address <> adr
                End If
        Next
        For Each c In .Range("D2", .Cells(Rows.Count, 4).End(xlUp))
            If c.Value > 0 And c.Offset(, -1).Value <> "X" Then
                Set fn = sh2.Range("C:C").Find(c.Value, , xlValues, xlPart)
                    If Not fn Is Nothing Then
                        If Len(c) = Len(fn) Then
                            c.Offset(, -3) = "Y"
                            fn.Offset(, -2) = "Y"
                        End If
                    End If
            End If
        Next
    End With
End Sub


Point 05 - What is the issue so far ;

05.1 - For now I have found the Macro is detecting Zero's (Cells are on Accounting format) and it identifies Zero's as Duplicates as well.
05.2 - In some instances I found "X/Y" appears only in one sheet despite an entry having been identified as a Duplicate.

I am no expert of VBA.

Please help me out.

Thank you.
 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,147
This is the penultimate version!
I revised the code to cope for my latest understandings; also modified the way X/Y are written into the columns to improve the timing
Based on the tOne and tTwo definition, I assume that the table is 6 columns wide and its heigth is till the last used row in those 6 columns (no need for empty column or row)

The code:
VBA Code:
Sub DuplXY22()
Dim tOne As Range, tTwo As Range, T1CR As Range, T2CR As Range, I As Long, J As Long
Dim Last1 As Long, Last2 As Long, C1X As Long, C2X As Long
Dim OArr()
'
Set tOne = Sheets("F1 - B.Stat").Range("C15")     '<<< Start of first table
Set tTwo = Sheets("F1 - LedG").Range("C15")       '<<< Start of second table
'

'lastc = tOne.Cells(1, 1).End(xlToRight).Column

'LastR = tOne.Cells(1, 1).Resize(10000, lastc).Find(What:="*", After:=[A1], _
'LastR = range.Find(What:="*", After:=[A1], _

On Error Resume Next
lastr1 = tOne.Cells(1, 1).Resize(10000, 6).Find(What:="*", After:=tOne.Cells(10000, 1), _
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastr2 = tTwo.Cells(1, 1).Resize(10000, 6).Find(What:="*", After:=tTwo.Cells(10000, 1), _
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
'
For J = 1 To 2
    If J = 1 Then
        Set T1CR = tOne.Cells(1, 1).Resize(lastr1)
        Set T2CR = tTwo.Cells(1, 1).Resize(lastr2)
    Else
        Set T2CR = tOne.Cells(1, 1).Resize(lastr1)
        Set T1CR = tTwo.Cells(1, 1).Resize(lastr2)
    End If
    Last1 = T1CR.Rows.Count
    Last2 = T2CR.Rows.Count
    ReDim OArr(1 To Last1)
    For I = 2 To Last1
        If J = 1 Then
            C1X = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 3).Resize(Last2, 1), T1CR.Cells(I, 3), T2CR.Cells(1, 6).Resize(Last2, 1), T1CR.Cells(I, 5) + 9999.8765 * (T1CR.Cells(I, 5) = 0))
            C1y = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 5).Resize(Last2, 1), T1CR.Cells(I, 6) + 9999.8765 * (T1CR.Cells(I, 6) = 0))
        Else
            C1y = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 3).Resize(Last2, 1), T1CR.Cells(I, 3), T2CR.Cells(1, 5).Resize(Last2, 1), T1CR.Cells(I, 6) + 9999.8765 * (T1CR.Cells(I, 6) = 0))
            C1X = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 6).Resize(Last2, 1), T1CR.Cells(I, 5) + 9999.8765 * (T1CR.Cells(I, 5) = 0))
        End If
        If C1X > 0 Then
            OArr(I - 1) = "X"
        ElseIf C1y > 0 Then
            OArr(I - 1) = "Y"
        End If
    Next I
    T1CR.Cells(2, 1).Resize(Last1, 1) = Application.WorksheetFunction.Transpose(OArr)
Next J
MsgBox ("Auto-Reconciliation Completed")
End Sub
There are a few modification here and there

Try...
 

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Please_H

Board Regular
Joined
Apr 16, 2017
Messages
181
Office Version
  1. 2019
Platform
  1. Windows
This is the penultimate version!
I revised the code to cope for my latest understandings; also modified the way X/Y are written into the columns to improve the timing
Based on the tOne and tTwo definition, I assume that the table is 6 columns wide and its heigth is till the last used row in those 6 columns (no need for empty column or row)

The code:
VBA Code:
Sub DuplXY22()
Dim tOne As Range, tTwo As Range, T1CR As Range, T2CR As Range, I As Long, J As Long
Dim Last1 As Long, Last2 As Long, C1X As Long, C2X As Long
Dim OArr()
'
Set tOne = Sheets("F1 - B.Stat").Range("C15")     '<<< Start of first table
Set tTwo = Sheets("F1 - LedG").Range("C15")       '<<< Start of second table
'

'lastc = tOne.Cells(1, 1).End(xlToRight).Column

'LastR = tOne.Cells(1, 1).Resize(10000, lastc).Find(What:="*", After:=[A1], _
'LastR = range.Find(What:="*", After:=[A1], _

On Error Resume Next
lastr1 = tOne.Cells(1, 1).Resize(10000, 6).Find(What:="*", After:=tOne.Cells(10000, 1), _
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastr2 = tTwo.Cells(1, 1).Resize(10000, 6).Find(What:="*", After:=tTwo.Cells(10000, 1), _
    SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
'
For J = 1 To 2
    If J = 1 Then
        Set T1CR = tOne.Cells(1, 1).Resize(lastr1)
        Set T2CR = tTwo.Cells(1, 1).Resize(lastr2)
    Else
        Set T2CR = tOne.Cells(1, 1).Resize(lastr1)
        Set T1CR = tTwo.Cells(1, 1).Resize(lastr2)
    End If
    Last1 = T1CR.Rows.Count
    Last2 = T2CR.Rows.Count
    ReDim OArr(1 To Last1)
    For I = 2 To Last1
        If J = 1 Then
            C1X = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 3).Resize(Last2, 1), T1CR.Cells(I, 3), T2CR.Cells(1, 6).Resize(Last2, 1), T1CR.Cells(I, 5) + 9999.8765 * (T1CR.Cells(I, 5) = 0))
            C1y = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 5).Resize(Last2, 1), T1CR.Cells(I, 6) + 9999.8765 * (T1CR.Cells(I, 6) = 0))
        Else
            C1y = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 3).Resize(Last2, 1), T1CR.Cells(I, 3), T2CR.Cells(1, 5).Resize(Last2, 1), T1CR.Cells(I, 6) + 9999.8765 * (T1CR.Cells(I, 6) = 0))
            C1X = Application.WorksheetFunction.CountIfs(T2CR.Cells(1, 6).Resize(Last2, 1), T1CR.Cells(I, 5) + 9999.8765 * (T1CR.Cells(I, 5) = 0))
        End If
        If C1X > 0 Then
            OArr(I - 1) = "X"
        ElseIf C1y > 0 Then
            OArr(I - 1) = "Y"
        End If
    Next I
    T1CR.Cells(2, 1).Resize(Last1, 1) = Application.WorksheetFunction.Transpose(OArr)
Next J
MsgBox ("Auto-Reconciliation Completed")
End Sub
There are a few modification here and there

Try...


Sorry for the Delayed Response Bro,
Time difference :)

Yeah seems like finally we've done it mannn...
FINALY !!!
Thanks a lot for your hardwork Bro...
I really really appreciate your support and for being patient with an excel Newbie.
And I am sorry if I had annoyed you by any means due to some communication misunderstanding...
I did run it in one test sample and it fabulously gave what I had been expecting for so so long...
Btw the "X" and "Y" was placed other way around for the 2nd sheet like the last time and I changed it.
let me run it in couple of more test batches and update you on the test result...
 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,147
Glad to know we are hopefully over
Btw, if I didn't understand up to now how the X and Y have to be set it means I shall never discover it :cool:
Bye
 

Please_H

Board Regular
Joined
Apr 16, 2017
Messages
181
Office Version
  1. 2019
Platform
  1. Windows
Glad to know we are hopefully over
Btw, if I didn't understand up to now how the X and Y have to be set it means I shall never discover it :cool:
Bye

GUESS WHAT?
GUESS WHAT?

WE'VE DONE IT MAN...:eek::eek::eek:
Actually NOT WE...:)

YOU'VE Done it ma man... :love: :love: :love: :love: :love: :love: :love:
Appreciate the Patience you had with me and your effort.
Wish I was able to buy you a nice Beverage and Big Fat Cheesy Pizza...
One day in Italy may be...

Thank you again Sir.
Stay Safe from Covid19.
Tc.
 

Watch MrExcel Video

Forum statistics

Threads
1,128,141
Messages
5,628,947
Members
416,354
Latest member
JojoMaque

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
Top