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

Please_H

Please_H

Board Regular
Joined
Apr 16, 2017
Messages
181
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
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.
 
Sort by date Sort by votes
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...
 
Upvote 0

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
Anthony47 said:
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...
Click to expand...


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...
 
Upvote 0
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
 
Upvote 0
Anthony47 said:
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
Click to expand...

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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Excel VBA building 2d array 1 col at a time in separate for loops OR multiplying a 1d array x another 1d array
2
Replies
10
Views
2K
Fazza
F
S
  • Question Question
copy from one sheet to another updating sheet 2 please help on deadline
Replies
1
Views
363
sharper092
S

Forum statistics

Threads
1,223,909
Messages
6,175,314
Members
452,634
Latest member
cpostell

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