Excel VBA Search For Find Duplicate Values In Two Lists

**PcMax** · 04-20-2013, 01:51 PM

Hi,

I ask for suggestions to change the code in an efficient way by using arrays ...
I have two columns of unique values and sorted in ascending order

A
112
144
156
184
222

D
111
144
156
188

E=
144
156

Code:

Sub CercaeTrova()
    Dim Righetot As Integer
    Dim Riga As Integer
    Dim Riga1 As Integer
    Dim RigaCodice As Integer
    With ActiveSheet
        RigaCodice = 1
    
        Righetot = .[A1].End(xlDown).Row
        For Riga = 1 To Righetot
            For Riga1 = 1 To Righetot
                If .Cells(Riga1, 4).Value = .Cells(Riga, 1).Value Then
                    .Cells(RigaCodice, 5).Value = .Cells(Riga, 1).Value
                    RigaCodice = RigaCodice + 1
                End If
            Next
        Next
    End With
End Sub

Your assistance in this regard is most appreciated

**LalitPandey87** · 04-20-2013, 03:21 PM

Try this:
VarFinalArr is the Final result with duplicate value in both array

Code:

Option Explicit
Option Compare Text


Sub LMP_Test()


    Dim varFirstArr()                   As Variant
    Dim varSecondArr()                  As Variant
    Dim varFinalArr()                   As Variant
    Dim lngLoop                         As Long
    Dim lngIndex                        As Long
    Dim lngCount                        As Long
    
    With Worksheets("Sheet1")
        varFirstArr = .Range("A1:A5").Value
        varSecondArr = .Range("B1:B4").Value
    End With
    
    lngCount = 1
    For lngLoop = LBound(varFirstArr) To UBound(varFirstArr)
        lngIndex = 0
        lngIndex = GetArrayIndex(varFirstArr(lngLoop, 1), varSecondArr, False)
        If lngIndex > 0 Then
            lngIndex = 0
            ReDim Preserve varFinalArr(1 To lngCount)
            varFinalArr(lngCount) = varFirstArr(lngLoop, 1)
            lngCount = lngCount + 1
        End If
    Next lngLoop
    
    Erase varFirstArr
    Erase varSecondArr
    Erase varFinalArr
    lngLoop = Empty
    lngIndex = Empty
    lngCount = Empty


End Sub


Function GetArrayIndex(ByVal Val As Variant, ByVal varArr As Variant, _
                       Optional blnTranspose As Boolean = True, Optional lngColNo As Long = 1, _
                       Optional blnMatcase As Boolean = False) As Long


    Dim varDataArr              As Variant
    
    GetArrayIndex = 0
    On Error Resume Next
    With WorksheetFunction
        If blnTranspose Then
            varDataArr = .Index(Application.Transpose(varArr), lngColNo)
        Else
            varDataArr = varArr
        End If
        GetArrayIndex = .Match(Val, varDataArr, blnMatcase)
    End With
    On Error GoTo -1: On Error GoTo 0: Err.Clear
    
    varDataArr = Empty


End Function

**PcMax** · 04-20-2013, 03:53 PM

Hi,

Thanks for the suggestions LalitPandey87

I tested the code and adding the following line to insert the data sheet

Code:

Worksheets("Sheet1").Range("H1:H" & UBound(varFinalArr)) = Application.Transpose(varFinalArr)

**LalitPandey87** · 04-20-2013, 05:21 PM

you can also do it as below:

Code:

Worksheets("Sheet1").Range("H1").Resize(UBound(varFinalArr)).value = Application.Transpose(varFinalArr)

**princ_wns** · 04-22-2013, 09:11 AM

You may Also try this

Code:

Sub getCommon()
    
    Dim obj                 As Object
    Dim lngRow              As Long
    Dim intCell             As Integer
    
    Dim varDataS             As Variant
    Dim varDataT             As Variant
    
    Const strSheetName      As String = "Sheet1"
    Const strRangSrc        As String = "A1"
    Const strRangTrg        As String = "C1"
    
    
    intCell = 1
    Set obj = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets(strSheetName)
        varDataS = Application.Transpose(.Range(strRangSrc).CurrentRegion.Columns(1))
        varDataT = Application.Transpose(.Range(strRangTrg).CurrentRegion.Columns(1))
        For lngRow = LBound(varDataT) To UBound(varDataT)
          With obj
            If .exists(varDataS(lngRow)) = False Then
                .Add varDataS(lngRow), varDataS(lngRow)
            End If
          End With
        Next
        For lngRow = LBound(varDataT) To UBound(varDataT)
            If obj.Item(varDataT(lngRow)) <> "" Then
                .Range("E" & intCell).Value = obj.Item(varDataT(lngRow))
                intCell = intCell + 1
            End If
        Next
    End With
    
End Sub

regards
Prince

**Rick Rothstein** · 04-22-2013, 09:59 AM

Here is a slightly shorter, non-looping macro that will do what you want as well (just change the assignments in the Const statements I highlighted in red to match your actual setup)...

Code:

Sub ListDupes()
  Dim LastRow As Long, List2Address As String
  Const WS As String = "Sheet2"
  Const List1Col As String = "A"
  Const List2Col As String = "D"
  Const OutputCol As String = "E"
  Const StartRow As Long = 2
  LastRow = Worksheets(WS).Cells(Rows.Count, List2Col).End(xlUp).Row
  List2Address = List2Col & StartRow & ":" & List2Col & LastRow
  Application.ScreenUpdating = False
  With Worksheets(WS).Cells(StartRow, OutputCol).Resize(LastRow - StartRow + 1)
    .Cells = Evaluate("IF(COUNTIF('" & WS & "'!" & List1Col & ":" & List1Col & ",'" & WS & _
                      "'!" & List2Address & "),'" & WS & "'!" & List2Address & ","""")")
    On Error Resume Next
    .SpecialCells(xlBlanks).Delete xlShiftUp
    On Error GoTo 0
  End With
  Application.ScreenUpdating = True
End Sub

**PcMax** · 04-22-2013, 12:41 PM

Hi,

Thank you all for the various suggestions

Here is the code I use

Code:

Option Explicit
Option Compare Text

Sub Test_AN()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    
'-- Areas of Verification
    Dim cl              As Variant
    Dim clx             As Variant
    
    Dim varFirstArr()   As Variant
    Dim varSecondArr()  As Variant
    Dim varFinalArr()   As Variant
    Dim lngLoop         As Long
    Dim lngIndex        As Long
    Dim lngCount        As Long
    Dim PanSx           As Integer
    Dim LastSx          As Integer
    Dim LastDx          As Integer
    Dim CicloAN         As Integer
    Dim RC As Long
    
    RC = Rows.Count
'---Column on the left to compare
    PanSx = 1
    
'---References of Cycles
    Dim Ciclo As Long
    
'---references Columns
    Dim Col_Pos As Long
    
'---I put the column where the Parameter Data Set
    Col_Pos = 20
    
    Call Imposta_Fogli.Imposta_Fogli
    Dim Lista(1 To 12, 1 To 1)
    
    Dim AreaR As Variant
    AreaR = F6.Range("C23:G23")
    
    Dim AreaS
    AreaS = F6.Range("C26:C30")
    
    Dim r As Range, s As Range
    
    With FAB
        .Select
    '---I clean the lines of the sheet
        .[L15].Copy
        .Range("T7:CG200").PasteSpecial Paste:=xlFormats
    '---I create a list with the positions of the last row of columns AN
        For Ciclo = 1 To 12
            Lista(Ciclo, 1) = .Cells(RC, Ciclo).End(xlUp).Row
        Next
        Set r = Cells(5, 20)
        Set s = r
        For CicloAN = PanSx To 12
            For Ciclo = PanSx + 1 To 12
                varFirstArr = .Range(Cells(7, CicloAN), Cells(Lista(CicloAN, 1), CicloAN)).Value
                varSecondArr = .Range(Cells(7, Ciclo), Cells(Lista(Ciclo, 1), Ciclo)).Value
                lngCount = 1
                For lngLoop = LBound(varFirstArr) To UBound(varFirstArr)
                    lngIndex = 0
                    lngIndex = GetArrayIndex(varFirstArr(lngLoop, 1), varSecondArr, False)
                    If lngIndex > 0 Then
                        lngIndex = 0
                        ReDim Preserve varFinalArr(1 To lngCount)
                        varFinalArr(lngCount) = varFirstArr(lngLoop, 1)
                        lngCount = lngCount + 1
                    End If
                Next lngLoop
                .Cells(7, Col_Pos).Resize(UBound(varFinalArr)).Value = Application.Transpose(varFinalArr)
                
                
                For clx = 1 To UBound(varFinalArr)
                    For Each cl In AreaR
                        If cl = varFinalArr(clx) Then Set r = Union(r, Cells(clx + 6, Col_Pos))
                    Next
                    
                    For Each cl In AreaS
                        If cl = varFinalArr(clx) Then Set s = Union(s, Cells(clx + 6, Col_Pos))
                    Next
                Next
                
                Col_Pos = Col_Pos + 1
            Next
            PanSx = PanSx + 1
            If PanSx = 12 Then Exit For
        Next CicloAN
        
        Erase varFirstArr
        Erase varSecondArr
        Erase varFinalArr
        lngLoop = Empty
        lngIndex = Empty
        lngCount = Empty
        AreaR = Empty
        AreaS = Empty
        .Range("T7").Select
    End With

    If Not r Is Nothing Then
        FAB.[L11].Copy
        r.PasteSpecial Paste:=xlFormats
        Set r = Nothing
    End If
    If Not s Is Nothing Then
        FAB.[L12].Copy
        s.PasteSpecial Paste:=xlFormats
        Set s = Nothing
    End If
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub


Function GetArrayIndex(ByVal Val As Variant, ByVal varArr As Variant, _
                       Optional blnTranspose As Boolean = True, Optional lngColNo As Long = 1, _
                       Optional blnMatcase As Boolean = False) As Long

    Dim varDataArr  As Variant
    
    GetArrayIndex = 0
    On Error Resume Next
    With WorksheetFunction
        If blnTranspose Then
            varDataArr = .Index(Application.Transpose(varArr), lngColNo)
        Else
            varDataArr = varArr
        End If
        GetArrayIndex = .Match(Val, varDataArr, blnMatcase)
    End With
    On Error GoTo -1: On Error GoTo 0: Err.Clear
    
    varDataArr = Empty


End Function

I have attached the cycle requires you to re-analyze data entered in sheet