excel - find the same words into different cells -

find common words in title of books in excel, output :

   '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    ' 

so here's shot @ problem. aware code rather messy: i've been sloppy variable names, error handling , on, gives idea of how can done. i've created udf common() takes 4 arguments:

• rngtext: reference single cell containing text (in case book) want comare
• comparelist: range of cells compare first argument
• minoccurences (optional): definition of minimum number of occurences word should have considered "common". default vanue 2
• exclusionlist (optional): range of cells containing text should excluded (e.g. words "a", "of", ...)

so example, if have titles in a2:a7 , exclusion list in e2:e3, use formula = common( a2, $a$2:$a$7, , $e$2:$e$3 )in cell b2 , copy down b7.

option explicit  function common(rngtext range, comparelist range, _     optional minoccurences integer = 2, optional exclusionlist range) variant      'check if exclusion list provided     dim exclusionlistprovided boolean     if not (exclusionlist nothing)         exclusionlistprovided = true     else         exclusionlistprovided = false     end if      'check argments     dim returnerror boolean     if isdate(rngtext.value) or isnumeric(rngtext.value) or iserror(rngtext.value) 'first argument should refer cell containing text        returnerror = true     elseif minoccurences < 2   'function should check @ least 2 occurences         returnerror = true     elseif (comparelist.columns.count > 1 , comparelist.rows.count > 1)  'comparelist should one-dimensional         returnerror = true     elseif exclusionlistprovided         if (exclusionlist.columns.count > 1 , exclusionlist.rows.count > 1)  'exclusionlist should one-dimensional             returnerror = true         end if     else         returnerror = false     end if      'return error if 1 of arguments unexpected     if returnerror         common = cverr(xlerrvalue)     else         dim text string         text = rngtext.value          'split text array of words         dim words() string         words = fullsplit(text)          'convert exclusionlist , comparelist arrays         dim arrexclude()         if exclusionlistprovided             arrexclude() = rangetostringarray(exclusionlist)         end if         dim arrcompare()         arrcompare() = rangetostringarray(comparelist)          dim strcommon string         'loop through words in text         dim integer         dim j integer         dim k integer         dim noccurences integer         dim excluded boolean         dim comparewords() string          = lbound(words) ubound(words)             'check if word in exclusion list             excluded = false             if exclusionlistprovided                 j = lbound(arrexclude) ubound(arrexclude)                     comparewords = fullsplit(arrexclude(j))                     k = lbound(comparewords) ubound(comparewords)                         if comparewords(k) = words(i)                             excluded = true                             exit                         end if                     next k                     if excluded exit                 next j             end if              'count number of occurences of word in compare list             if not excluded                 noccurences = 0                 j = lbound(arrcompare) ubound(arrcompare)                     comparewords = fullsplit(arrcompare(j))                     k = lbound(comparewords) ubound(comparewords)                         if lcase(comparewords(k)) = lcase(words(i))                             noccurences = noccurences + 1                             exit                         end if                     next k                 next j                 if noccurences >= minoccurences                     if not strcommon = ""                         strcommon = strcommon & ", "                     end if                     strcommon = strcommon & lcase(words(i))                 end if             end if         next          common = strcommon     end if   end function  'split text using list of delimiters function fullsplit(text variant)     'define list of delimiters     dim delimiters()     delimiters = array(" ", ",", ".", ";", "?", "!")      'unique delimiter first 1 list     dim uniquedelimiter string     uniquedelimiter = delimiters(0)      'replace delimiters in text unique delimiter     dim integer     = lbound(delimiters) + 1 ubound(delimiters)         replace text, delimiters(i), uniquedelimiter     next      'split text using unique delimiter     fullsplit = splittext(text, uniquedelimiter)  end function  'split text using single delimiter function splittext(text variant, delimiter string)     'split text in substrings on each occurence of delimiter     dim temparray() string     temparray = split(text, delimiter)      'remove empty substrings     dim lastnonempty integer     lastnonempty = -1     dim integer     = lbound(temparray) ubound(temparray)         if temparray(i) <> ""             lastnonempty = lastnonempty + 1             temparray(lastnonempty) = temparray(i)         end if     next     redim preserve temparray(0 lastnonempty)      splittext = temparray end function  'check if 2 arrays share least 1 element function sharedelements(array1() variant, array2() variant) boolean     dim found boolean     found = false      dim integer     dim j integer     = lbound(array1) ubound(array1)         j = lbound(array2) ubound(array2)             if array1(i) = array2(j)                 found = true                 exit             end if         next j         if found = true exit     next      sharedelements = found end function  'converts range array of strings, omitting non-text cells function rangetostringarray(myrange range)     dim myarray()     dim arraysize integer     arraysize = 0      dim c object     each c in myrange         if isdate(c.value) = false , isnumeric(c.value) = false , iserror(c.value) = false             redim preserve myarray(arraysize)             myarray(arraysize) = c.value             arraysize = arraysize + 1         end if     next      rangetostringarray = myarray end function