Copy Duplicate stock name from two sheets into new sheet

[Johsmite]

I am using the below code to find duplicate stock name from two sheets and copy duplicate stock into another sheet. But getting error when I change the column "B" as "D"
as my stock is in column "D". Experts, can you all please help me to solve this issue as I am very beginner to vba code. Below is the Excel on which I am working.

Sub CopyDuplicates2sheets()
MsgBox "Process begin now. if you cannot see any result after processing, " & _
"it means there is no duplicate data between two sheets."

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
Dim ar As Variant, i As Long

Set ws1 = Sheets("BATSUS")
Set ws2 = Sheets("RECTUS")
Set ws3 = Sheets("WList")
ws3.Cells.Clear

lr1 = ws1.UsedRange.Rows.Count
lr2 = ws2.UsedRange.Rows.Count
ws1.UsedRange.Interior.ColorIndex = xlNone
ws2.UsedRange.Interior.ColorIndex = xlNone

' build dictionary from sheet2 col B
Dim dict, key As String
Set dict = CreateObject("Scripting.Dictionary")

For r = 1 To lr2
key = Trim(ws2.Cells(r, "B"))
If Len(key) > 0 Then
If dict.exists(key) Then
dict(key) = dict(key) & ";" & r
Else
dict.Add key, r
End If
End If
Next

Application.ScreenUpdating = False
r3 = 1 ' sheet3
' scan sheet 1 looking for to match with sheet 2
For r = 1 To lr1
key = Trim(ws1.Cells(r, "B"))
If dict.exists(key) Then
' copy multiple matches
ar = Split(dict(key), ";")
For i = LBound(ar) To UBound(ar)
ws1.Range("A" & r).Resize(1, 16).Copy ws3.Range("A" & r3) ' A:F
ws2.Range("A" & ar(i)).Resize(1, 15).Copy ws3.Range("T" & r3) ' A:Q
r3 = r3 + 1
Next
End If
Next

Worksheets("WList").Activate
With ActiveSheet
.AutoFilterMode = False
.Range("B2").AutoFilter
.Range("B2").AutoFilter Field:=1, Criteria1:="<0"
.AutoFilter.Range.Offset(1).EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
MsgBox "Process finished"
End Sub

 

[nemmi69]

Can you show which line returns the error and what the error says

 

[abdelfattah]

actually I don't test your code

But getting error when I change the column "B" as "D"

change any line contains column B to D and see how works

 

[Johsmite]

Can you show which line returns the error and what the error says

When I change column "B" to "D" then getting below error. I want duplicate stock name, so I need to change the column as "D". I think, so the error might be due to data type as "B" is number and when I change to "D" it is stock name that is string.

 

[Johsmite]

actually I don't test your code

change any line contains column B to D and see how works

If I change Column B to D then getting below error.

 

[nemmi69]

Odd so I tried it on numbers (in B)

Sub Nergle()
Dim dict, key As String
Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
Dim k As Variant

Set dict = CreateObject("Scripting.Dictionary")
Set Ws2 = Sheets(2)

lr2 = 5

For r = 1 To lr2
    key = Trim(Ws2.Cells(r, "B"))
    If Len(key) > 0 Then
        If dict.exists(key) Then
            MsgBox "dict key exists" & dict(key)
            dict(key) = dict(key) & ";" & r
        Else
            dict.Add key, r
        End If
    End If
Next

lr2 = 1
For Each k In dict.Keys
    ' Print key and value
    Ws2.Range("G" & lr2).Value = k
    lr2 = lr2 + 1
Next
End Sub

Result

and tried it on text (in C)

Sub Nergle()
Dim dict, key As String
Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
Dim k As Variant

Set dict = CreateObject("Scripting.Dictionary")
Set Ws2 = Sheets(2)

lr2 = 5

For r = 1 To lr2
    key = Trim(Ws2.Cells(r, "C"))
    If Len(key) > 0 Then
        If dict.exists(key) Then
            MsgBox "dict key exists" & dict(key)
            dict(key) = dict(key) & ";" & r
        Else
            dict.Add key, r
        End If
    End If
Next

lr2 = 1
For Each k In dict.Keys
    ' Print key and value
    Ws2.Range("G" & lr2).Value = k
    lr2 = lr2 + 1
Next
End Sub

Result

No errors

 

[Johsmite]

View attachment 66144
Odd so I tried it on numbers (in B)

Sub Nergle()
Dim dict, key As String
Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
Dim k As Variant

Set dict = CreateObject("Scripting.Dictionary")
Set Ws2 = Sheets(2)

lr2 = 5

For r = 1 To lr2
    key = Trim(Ws2.Cells(r, "B"))
    If Len(key) > 0 Then
        If dict.exists(key) Then
            MsgBox "dict key exists" & dict(key)
            dict(key) = dict(key) & ";" & r
        Else
            dict.Add key, r
        End If
    End If
Next

lr2 = 1
For Each k In dict.Keys
    ' Print key and value
    Ws2.Range("G" & lr2).Value = k
    lr2 = lr2 + 1
Next
End Sub

Result
View attachment 66145

and tried it on text (in C)

Sub Nergle()
Dim dict, key As String
Dim lr1 As Long, lr2 As Long, r As Long, r3 As Long
Dim k As Variant

Set dict = CreateObject("Scripting.Dictionary")
Set Ws2 = Sheets(2)

lr2 = 5

For r = 1 To lr2
    key = Trim(Ws2.Cells(r, "C"))
    If Len(key) > 0 Then
        If dict.exists(key) Then
            MsgBox "dict key exists" & dict(key)
            dict(key) = dict(key) & ";" & r
        Else
            dict.Add key, r
        End If
    End If
Next

lr2 = 1
For Each k In dict.Keys
    ' Print key and value
    Ws2.Range("G" & lr2).Value = k
    lr2 = lr2 + 1
Next
End Sub

Result
View attachment 66146


No errors

Can you try for stock data instead of plain text because I try your code for stock data, still getting error.

 

[nemmi69]

What is that image on the front of your stock list? That may be the issue

 

[nemmi69]

With the stock name (minus that thing)

 

[Fluff]

What is that image on the front of your stock list? That may be the issue

It indicates that it is a stock-data type Excel data types: Stocks and geography