find the same words into different cells - excel

Question

find the common words in title of the books in Excel, the output like this :
'book common user_id
physics physics 1
Principles of plasma physics physics,plasma 2
Fundamentals of plasma physics fundamentals,plasma,physics 3
Fundamentals of thermodynamics fundamentals 4
'

Answer 1

So here's my shot at this problem. I am aware that the code is rather messy: I've been very sloppy with variable names, error handling and so on, but it gives you an idea of how it can be done. I've created a UDF Common() which takes 4 arguments:
rngText: a reference to a single cell containing the text (in your case book) you want to comare
compareList: a range of cells with which to compare the first argument
minOccurences (optional): this is the definition of the minimum number of occurences a word should have to be considered "common". The default vanue is 2
exclusionList (optional): a range of cells containing text that should be excluded (e.g. words like "a", "of", ...)
So for example, if you have your titles in A2:A7 and your exclusion list in E2:E3, you could use the formula = Common( A2, $A$2:$A$7, , $E$2:$E$3 )in cell B2 and copy down to B7.
Option Explicit
Function Common(rngText As Range, compareList As Range, _
Optional minOccurences As Integer = 2, Optional exclusionList As Range) As Variant
'Check if an exclusion list is provided
Dim exclusionListProvided As Boolean
If Not (exclusionList Is Nothing) Then
exclusionListProvided = True
Else
exclusionListProvided = False
End If
'Check the argments
Dim returnError As Boolean
If IsDate(rngText.Value) Or IsNumeric(rngText.Value) Or IsError(rngText.Value) Then 'first argument should refer to a cell containing text
returnError = True
ElseIf minOccurences < 2 Then 'Function should check for at least 2 occurences
returnError = True
ElseIf (compareList.Columns.Count > 1 And compareList.Rows.Count > 1) Then 'compareList should be one-dimensional
returnError = True
ElseIf exclusionListProvided Then
If (exclusionList.Columns.Count > 1 And exclusionList.Rows.Count > 1) Then 'exclusionList should be one-dimensional
returnError = True
End If
Else
returnError = False
End If
'Return an error if one of the arguments is unexpected
If returnError Then
Common = CVErr(xlErrValue)
Else
Dim text As String
text = rngText.Value
'split text into an array of words
Dim words() As String
words = fullSplit(text)
'convert exclusionlist and compareList to arrays
Dim arrExclude()
If exclusionListProvided Then
arrExclude() = rangeToStringArray(exclusionList)
End If
Dim arrCompare()
arrCompare() = rangeToStringArray(compareList)
Dim strCommon As String
'loop through words in text
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim nOccurences As Integer
Dim excluded As Boolean
Dim compareWords() As String
For i = LBound(words) To UBound(words)
'check if word is in exclusion list
excluded = False
If exclusionListProvided Then
For j = LBound(arrExclude) To UBound(arrExclude)
compareWords = fullSplit(arrExclude(j))
For k = LBound(compareWords) To UBound(compareWords)
If compareWords(k) = words(i) Then
excluded = True
Exit For
End If
Next k
If excluded Then Exit For
Next j
End If
'count the number of occurences of the word in the compare list
If Not excluded Then
nOccurences = 0
For j = LBound(arrCompare) To UBound(arrCompare)
compareWords = fullSplit(arrCompare(j))
For k = LBound(compareWords) To UBound(compareWords)
If LCase(compareWords(k)) = LCase(words(i)) Then
nOccurences = nOccurences + 1
Exit For
End If
Next k
Next j
If nOccurences >= minOccurences Then
If Not strCommon = "" Then
strCommon = strCommon & ", "
End If
strCommon = strCommon & LCase(words(i))
End If
End If
Next i
Common = strCommon
End If
End Function
'split text by using a list of delimiters
Function fullSplit(text As Variant)
'define list of delimiters
Dim delimiters()
delimiters = Array(" ", ",", ".", ";", "?", "!")
'unique delimiter is the first one from the list
Dim uniqueDelimiter As String
uniqueDelimiter = delimiters(0)
'replace all delimiters in the text by the unique delimiter
Dim i As Integer
For i = LBound(delimiters) + 1 To UBound(delimiters)
Replace text, delimiters(i), uniqueDelimiter
Next i
'split the text by using the unique delimiter
fullSplit = SplitText(text, uniqueDelimiter)
End Function
'split text by using a single delimiter
Function SplitText(text As Variant, delimiter As String)
'split the text in substrings on each occurence of the delimiter
Dim tempArray() As String
tempArray = Split(text, delimiter)
'remove empty substrings
Dim LastNonEmpty As Integer
LastNonEmpty = -1
Dim i As Integer
For i = LBound(tempArray) To UBound(tempArray)
If tempArray(i) <> "" Then
LastNonEmpty = LastNonEmpty + 1
tempArray(LastNonEmpty) = tempArray(i)
End If
Next
ReDim Preserve tempArray(0 To LastNonEmpty)
SplitText = tempArray
End Function
'check if two arrays share a least one element
Function sharedElements(array1() As Variant, array2() As Variant) As Boolean
Dim found As Boolean
found = False
Dim i As Integer
Dim j As Integer
For i = LBound(array1) To UBound(array1)
For j = LBound(array2) To UBound(array2)
If array1(i) = array2(j) Then
found = True
Exit For
End If
Next j
If found = True Then Exit For
Next i
sharedElements = found
End Function
'converts a range to an array of strings, omitting all non-text cells
Function rangeToStringArray(myRange As Range)
Dim myArray()
Dim arraySize As Integer
arraySize = 0
Dim c As Object
For Each c In myRange
If IsDate(c.Value) = False And IsNumeric(c.Value) = False And IsError(c.Value) = False Then
ReDim Preserve myArray(arraySize)
myArray(arraySize) = c.Value
arraySize = arraySize + 1
End If
Next
rangeToStringArray = myArray
End Function