Excel VBA Search For Find Duplicate Values In Two Lists

[PcMax]

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


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]

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



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]

Hi,

Thanks for the suggestions LalitPandey87

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


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

[LalitPandey87]

you can also do it as below:

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

[princ_wns]

You may Also try this


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).CurrentRe gion.Columns(1))
varDataT = Application.Transpose(.Range(strRangTrg).CurrentRe gion.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]

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)...

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]

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 ?