Excel VBA Search For Find Duplicate Values In Two Lists

[PcMax]

Hi,

Thank you all for the various suggestions

Here is the code I use

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

[princ_wns]

Can you Please share the workbook ?