How to show which keywords have duplicates, and how many?

[mmenashe]

I have an excel sheet with 4 columns

these are 4 competitors and the keywords they use in advertising

each column has a number of different words on each row
some of these keywords repeat across other columns(companies)

I want to find a way to identify which words repeat for other companies, and which companies they have repeated for

Here is the file if anyone wants to see it

 

[venkat1926]

I have tested these macros in your file. Your file is more than 7000 rows. This macro "test" takes nearly 30 seconds to run so you must have patience . Perhaps the macro can be tweaked to reduce the time.

see the results in coluns G and H

macro undo is to undo the result of the macro

TO BE ON SAFE SIDE COPY THE ORIGINAL DATA SOMEWHERE ELSE SO THAT THE FILE CAN BE RETRIEVED IF THERE IS A MESS UP.

Sub test()
Dim r As Range, j As Integer, k(1 To 4) As Integer, m As Integer, unq As Range
Dim cunq As Range, cfind As Range, dest As Range, com As String, keyword As String
Application.ScreenUpdating = False
Worksheets("sheet1").Activate
m = 0
For j = 1 To 4
k(j) = WorksheetFunction.CountA(Columns(j))
If k(j) > m Then m = k(j)
Next j
'msgbox m  'm is the last row
For j = 1 To 4
Range(Cells(2, j), Cells(2, j).End(xlDown)).Copy Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
Next j
Cells(1, "F") = "heading"
Set r = Range(Range("F1"), Range("F1").End(xlDown))
Set unq = Cells(m + 5, "A")
r.AdvancedFilter xlFilterCopy, , unq, True
Columns("F:F").Cells.Clear
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))
'Set dest = Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
For Each cunq In unq
For j = 1 To 4
With Range(Cells(2, j), Cells(2, j).End(xlDown))
Set cfind = .Cells.Find(what:=cunq.Value, lookat:=xlWhole)
If Not cfind Is Nothing Then
keyword = cfind.Value
com = Cells(1, cfind.Column)
'msgbox keyword
'msgbox com
GoTo fillup
Else
GoTo nextj
End If
End With
fillup:
Set dest = Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
'msgbox dest.Address
dest = keyword
dest.Offset(0, 1) = com
nextj:
Next j
Next cunq
Range("G1") = "keyword"
Range("H1") = "company"
Range(Cells(m + 5, 1), Cells(m + 5, 1).End(xlDown)).Cells.Clear
Application.ScreenUpdating = True
MsgBox "macro over"
End Sub

Sub undo()
Columns("G:H").Delete
End Sub

 

[mmenashe]

wow this is a hell of a macro
thank you so much, this works out and really gets me to the next step

I have a lot more work ahead of me, but youve helped me get somewhere

thanks

Matt