VBA - Find Duplicates in Column A and then check to see if there a cell value in Column B, Convert t-CodePudding

I have a vba macros that checks to see if there are duplicates in Column A & checks to see if there is a certain value in Column B but was wondering if there was a way to convert it to using with an array. The current code works great but I ran into a file that has over 153,000 rows in it & it takes the macros hours to run.

I can get it to find duplicates in Column A with an Array but can not figure out how to also check to see if it matches a certain value in Column B.

This is what I want it to do:

If match:

If not a match:

Here is the code I have right now to find duplicates not using an array:


Dim cell As Range
Dim wbook As Workbook
Dim wsheet As Worksheet
Dim sname As Range
Dim cname As Range
Dim rngA As Range
Dim dupA As Range
Dim dupB As Range
Dim strName As String


Set wbook = ActiveWorkbook 'Current Workbook
Set wsheet = Sheets("OFA_CP_OUT_202112_Without_Match") 'Worksheet Name
Set sname = Range("A2:H2426") 'Range for sorting and aligning columns A:H
Set cname = Sheets("OFA_CP_OUT_202112_Without_Match").Range("F2:F2426") 'Sheet Name & Range to format currency
Set rngA = Range("A2:A2426") 'Range to change column A to uppercase & find if a cell contains an A, B or S
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
strName = "202112" 'year & month to search for in column B

'Looks for duplicates and highlights them yellow in column A & column B
For Each cell In dupA
        If WorksheetFunction.CountIfs(dupA, "=" & cell.Value, dupB, "=" & cell.Offset(0, 1).Value) > 1 Then
            cell.Interior.ColorIndex = 6
            cell.Offset(0, 1).Interior.ColorIndex = 6
        End If
    Next cell

Here is the code that I got working using an array to find duplicates:


Sub Dupes()

Dim Ws As Worksheet
Dim LastRow As Long, i As Long, j As Long, DupCounter As Long, DupPos As Long
Dim MatNo As String
Dim Found As Boolean
Dim ArrDuplicates() As Variant 'Declare dynamic array

Set Ws = ThisWorkbook.Sheets(1)

'Redimennsion/change size of declared array
ReDim ArrDuplicates(1 To 2, 1 To 1)

DupCounter = 1

With Ws
    'find last row with data in column "A"
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    'Loop all rows from 1 to last
    For i = 1 To LastRow
        'reset variables for each loop
        Found = False
        DupPos = 0
        MatNo = .Cells(i, 1)
        'Search array with previous data and look for duplicates
        For j = LBound(ArrDuplicates(), 2) To UBound(ArrDuplicates(), 2)
           'If material number currently checked found in array
            If MatNo = ArrDuplicates(1, j) Then
                'remember position of source data in array (first occurence
                'of material number)
                DupPos = j
                'set "Found" marker
                Found = True
                'leave loop
                Exit For
            End If
        Next j

        'if no duplicate found
        If Not Found Then
            'redimension array. "Preserve" keyword added to keep values
            'already existing in array
            ReDim Preserve ArrDuplicates(1 To 2, 1 To DupCounter)
            'insert new data to array ((first occurance of material number)
            ArrDuplicates(1, DupCounter) = MatNo
            DupCounter = DupCounter   1 'increase counter used to redimension array
        Else  'if material number found in array
            'change font color
            .Cells(i, 1).Font.Color = vbRed       
        End If
    Next i
End With

End Sub

Thanks for your help!

CodePudding user response：

This should be faster:

Sub FlagDups()

    Dim wb As Workbook, wsheet As Worksheet
    Dim dupA As Range, arrA, dupB As Range, arrB
    Dim dict As Object, i As Long, k, rng As Range
    Set dict = CreateObject("scripting.dictionary")
    
    Set wb = ActiveWorkbook
    Set wsheet = wb.Worksheets("OFA_CP_OUT_202112_Without_Match")
    Set dict = CreateObject("scripting.dictionary")
    
    Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
    Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
    arrA = dupA.Value 'read all the data
    arrB = dupB.Value
    
    wsheet.Range("A1:B10000").Interior.ColorIndex = xlNone 'clear any existing fill
    
    For i = LBound(arrA) To UBound(arrA)          'loop over the data arrays
        k = arrA(i, 1) & Chr(0) & arrB(i, 1)      'composite key from A, B
        If Not dict.exists(k) Then   
            dict.Add k, i                         'novel pair of values: store row index
        Else
            If dict(k) > 0 Then                   'need to process store row index?
                addCell rng, dupA.Cells(dict(k))  'collect the first instance of this pair
                addCell rng, dupB.Cells(dict(k))
                dict(k) = 0                       'flag as collected
            End If
            addCell rng, dupA.Cells(i) 'collect current instance
            addCell rng, dupB.Cells(i)
        End If
    Next i
    
    If Not rng Is Nothing Then rng.Interior.Color = vbYellow  'any cells to color?
    
End Sub

'build a range by adding rngAdd to rngTot
Sub addCell(rngTot As Range, rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub

CodePudding user response：

I am not an expert but couldn't you just make a giant string and search the string with InStr?

Something like that:

Dim count as Double

Dim giantstring as String

Do While count <= maxcount

giantstring = count & " " & Cell(count, 1) & " " & count & " " & Cell(count, 2) & " "

count = count 1

Loop

And then search the position with InStr and extract the count with left() and right().