Checking for duplicate substrings in Excel - arrays

Question

I am trying to find a way to compare the first significant words in each cell with first significant words in the next cell, and if the first significant words matches, it removes the second entry. For example, the starting data can look like this:
General Electric
General Electric Inc
General Electric Company
Microsoft
Microsoft Corporation
Microsoft Servers
Nintendo
Nintendo Enterprises
And the result should end up looking like this:
General Electric
Microsoft
Nintendo
So far, I have this code set up that traverses the column of data:
Sub CompanyNameConsolidate()
Dim companyName As String
Dim companyArray() As String
Dim companyName2 As String
Dim companyArray2() As String
Dim totalArray() As String
Dim wordCount As Integer
Dim i As Integer
Dim r As Range
With Sheets("Unassigned")
Range("B1").Select
Do Until IsEmpty(ActiveCell)
companyName = Range("B" & ActiveCell.Row).Text
companyName2 = ActiveCell.Offset(1, 0).Text
companyArray = Split(companyName, " ")
companyArray2 = Split(companyName2, " ")
wordCount = UBound(companyArray) - LBound(companyArray)
For i = 0 To wordCount
If companyArray(i) = companyArray2(i) Then
[*********HELP**********]
Next
ActiveCell.Offset(1, 0).Select
Loop
End With
End Sub
Basically, the code above compares the substrings in each cell with the substrings in the next cell. Unfortunately, that's as far as I have gotten.
The tricky thing is that some company names can have two words (General Electric) and others can have only one word (Microsoft).
You can assume that the list will be sorted in alphabetical order, so the shortest name (the name I want to keep) will always be on top.
I have over 16,000 entries to go through and fix, so I absolutely must have an automated way of doing it!

Answer 1

1st variant using rows deletion:
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim x&, cl As Range, DataRange As Range, k1, k2
Dic.comparemode = vbTextCompare
With Sheets("Unassigned")
Set DataRange = .[B1].Resize(.Cells(Rows.Count, "B").End(xlUp).Row, 2)
x = 1
For Each cl In DataRange
If cl.Value <> "" Then
Dic.Add x, cl.Value
x = x + 1
End If
Next cl
For Each k1 In Dic
For Each k2 In Dic
If IsNumeric(k1) And IsNumeric(k2) Then
If Dic(k2) Like Dic(k1) + "*" And k2 > k1 Then
Dic.Remove (k2)
End If
If Not Dic.exists(Dic(k1)) Then Dic.Add Dic(k1), Nothing
End If
Next k2, k1
x = Split(DataRange.Address, "$")(4)
While x <> 0
If Not Dic.exists(.Cells(x, "B").Value) Then .Rows(x).Delete
x = x - 1
Wend
End With
End Sub
2nd variant using Workbook.Add:
Sub test2()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim x&, cl As Range, DataRange As Range, k1, k2
Dic.comparemode = vbTextCompare
With Sheets("Unassigned")
Set DataRange = .[B1].Resize(.Cells(Rows.Count, "B").End(xlUp).Row, 2)
x = 1
For Each cl In DataRange
If cl.Value <> "" Then
Dic.Add x, cl.Value
x = x + 1
End If
Next cl
For Each k1 In Dic
For Each k2 In Dic
If Dic(k2) Like Dic(k1) + "*" And k2 > k1 Then
Dic.Remove (k2)
End If
Next k2, k1
End With
Workbooks.Add
x = 1
For Each k1 In Dic
Cells(x, 2) = Dic(k1)
x = x + 1
Next k1
End Sub
test for both variants
before: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~> after:

Answer 2

Find a common demoninator for your company names, according to your examples this appears to just remove the last word, if its greater than 1 word.
Dim listOfCompanies As New Collection
Dim companyName As String
Dim companyArray As Variant
Dim item As Variant
Dim i as Integer, j As Integer
'The 2 denotes column B, where i denotes the row
'You can change this outter loop to your specific needs, this one just processes the first column B1, to when it encounters a blank row
while(ThisWorkbook.Worksheets("Unassigned").Cells(i, 2).Value <> "")
companyName = ThisWorkbook.Worksheets("Unassigned").Cells(i, 2).Value
companyArray = Split(companyName, " ")
companyName = ""
'This truncates the last word off
for j = 0 to UBound(companyArray) - 1
companyName = companyName + companyArray(j) + " "
next j
'Trim off the last space character
companyName = Trim(companyName)
'Now Add your companyName string to a Dictionary Object
'VBA will throw an error if a duplicate gets added, but this is okay and we can continue processing
On Error Resume Next
listOfCompanies.Add(companyName)
On Error Goto 0 'This resets the handler in case an error occurs somewhere else unexpectedly
i = i + 1
wend
'Now we can do a ForEach and spit out the entire 'unique list'
For Each item in listOfCompanies
'Your code here
Next item