Searching for Duplicates across columns and print to new column

[Guest]

I have multiple columns say 5 of them (1 every two columns starting in column
B and ending in column J). Each column has varying rows of string data. I
want to find the duplicate data across the columns and summarize in another
column 2 away from column J (column L). Hence column L will only show the
duplicate data found in the the 5 other columns. Note that there will not be
duplicate data within any one column. The duplicate data will only exist
across columns.

I am assuming that the best way to do this is to create a VBA 2D array,
define it by the colunn with the most rows of data and then load each column
into the array and search for duplicates from there. I am assuming that I
would then store the duplicates in another array and then dump the results to
column L.

Any insight on how to do this efficiently?

Thanks

 

[Guest]

Here is some code that I use. Place this in a standard module and reference
the "Micorsoft Scripting Runtime". Highlight the 5 columns to be searched for
duplicates and run the procedure. It will create a new sheet containing all
of the duplicates. With a little modification you should be able to make it
work the way you need.

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) And cell.Value <> Empty Then
'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter > 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub