CODEWITHSUNDEEP
excelvbaduplicates
smartini
smartini

Reputation: 455

Find duplicates based on multiple criteria and mark them

Background:
Column [3] of a table/listobject consists of Account Captions.
Column [4] consists of the Account Type.

Restrictions of the table:
The table allows only unique values in column [3]. This means that if "Payroll Expense" is already taken for Account Type "PL" it can't be used for other Account types other than "PL".

Examples:
I illustrated two examples in the screenshot.
1. Example: "Payroll expense" comes at "PL", "BS" and "Others". (yellow)
2. Example: "Other expenses" comes at "BS" and "PL". (red)

enter image description here

Use Case / desired solution:
If a caption is already taken for a specific Account Type and found linked to another Account Type the Caption should get a number at the end, counting upwards.

Example 1:
Payroll Expense // PL
Payroll Expense1 // BS
Payroll Expense2 // Others

Example 2:
Other expense // BS
Other expense1 // PL

What I have done so far. I also thought of a function which tells the algorithm that one "duplicate" was already found or not.

Hint: There only exist "PL", "BS" and "Others" - in total 3 Account Types, that means that the maximum integer number at the end of a Caption would be "2".

Sub checkDuplicateCaptionsWithinAccountType()
    Call declareVariables

    Dim sSearchCaption As String
    Dim sSearchAccountType As String
    counter = 0
    For n = 1 To 2
        counter = counter + 1
        With LObjAccounts
            For i = 1 To .DataBodyRange.Rows.Count
                sSearchCaption = .DataBodyRange.Cells(i, 3)
                sSearchAccountType = .DataBodyRange.Cells(i, 4)
                For j = 1 To .DataBodyRange.Rows.Count
                    If UCase(sSearchCaption) = UCase(.DataBodyRange.Cells(j, 3)) Then
                        If UCase(sSearchAccountType) <> UCase(.DataBodyRange.Cells(j, 4)) Then
                            .DataBodyRange.Cells(j, 3) = .DataBodyRange.Cells(j, 3) & counter
                        End If
                    End If
                Next j
            Next i
        End With
    Next n
    MsgBox "done."
End Sub

Function isAlreadyFound(ByVal sFind As String, ByRef arr) As Boolean

End Function

Upvotes: 1

Views: 656

Answers (1)

DecimalTurn
DecimalTurn

Reputation: 4129

The issue here is that you need more than one counter. You need one counter per account caption. Also, you can't just increase the counter when the line you are at is different from a specific line. You need to be able to keep track of every new caption-type pair and the value of the counter at that time (for that caption).

This seems like a good opportunity to use Scripting Dictionaries, since it can help you achieve what I mentioned above and it will allow you to do only one loop over the rows.

I would use one to store the different counters and one to store the value of the corresponding counter was at for each specific caption-type pair.

The code would look something like this:

Sub checkDuplicateCaptionsWithinAccountType()
    Call declareVariables

    Dim sSearchCaption As String
    Dim sSearchAccountType As String

    Dim Counters As Object 'Or: Scripting.Dictionary
    Set Counters = CreateObject("Scripting.Dictionary") 'Or: new Scripting.Dictionary

    Dim Pairs As Object 'Or: Scripting.Dictionary
    Set Pairs = CreateObject("Scripting.Dictionary") 'Or: new Scripting.Dictionary

    Const Delimiter As String = "-"

    With LObjAccounts
        For i = 1 To .DataBodyRange.Rows.Count
            sSearchCaption = .DataBodyRange.Cells(i, 3)
            sSearchAccountType = .DataBodyRange.Cells(i, 4)

            If Counters.Exists(sSearchCaption) Then 'If we have already seen this account caption

                If Pairs.Exists(sSearchCaption & Delimiter & sSearchAccountType) Then 'If we have seen this caption-type pair

                    'Do nothing since we don't increase the counter if we've already seen this pair

                Else

                    'We increase the counter for that caption since we just found a new caption-type pair
                    Counters.Item(sSearchCaption) = Counters.Item(sSearchCaption) + 1

                    'Save the counter number for this specific pair
                    Pairs.Add sSearchCaption & Delimiter & sSearchAccountType, Counters.Item(sSearchCaption)

                End If

            Else
                'We have'nt seen this caption so we create a new counter starting at zero
                Counters.Add sSearchCaption, 0

                'Save the counter number (zero) for this specific pair
                Pairs.Add sSearchCaption & Delimiter & sSearchAccountType, 0

            End If

            If Pairs.Item(sSearchCaption & Delimiter & sSearchAccountType) > 0 Then
                .DataBodyRange.Cells(i, 3) = .DataBodyRange.Cells(i, 3) & Pairs.Item(sSearchCaption & Delimiter & sSearchAccountType)
            End If

        Next i
    End With

    MsgBox "done."
End Sub

Note that I'm using the late binding method to declare the dictionaries since I don't know if you have a reference to the Microsoft Scripting Runtime library in your project.

Upvotes: 1

Related Questions