Finding key words in Excel with VBA - excel

Question

The file I am working on is picking the selected words from all the comments, colors them and segregates them into the dedicated tabs.
All keywords have been coded into the macro itself. Instead of writing the keywords to the macro, I want to tell the macro the keywords are located in an array in an excel sheet so everybody can use the file according to their needs.
When I made below changes for keywords to an array, I am getting below error on the screenshot that I do not know why.
Satellite:
KeyW = Array("Satellite", "image", "blacks out", "resolution")
Satellite:
KeyW = Array(Worksheets("MAIN").Range("N5:N15"))
The code below was not written by me. I just made some modifications.
Error that I am getting:
runtime error 13, Type mismatch
when I click debug it shows this yellow line
Sub sort()
Dim KeyW()
Dim cnt_Rows As Long, cnt_Columns As Long, curr_Row As Long, i As Long, x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets(Array("Television", "Satellite", "News", "Sports", "Movies", "Key2", "Key3", "Error", "Commercial", "Key4", "TV", "Key5", "Key6", "Signal", "Key1", "Key7", "Design", "Hardware")).Select
Satellite:
KeyW = Array("Satellite", "image", "blacks out", "resolution")
KeyWLen = UBound(KeyW, 1)
j = 2
For i = 0 To KeyWLen
With Worksheets(1).Range("c4:e7000")
Set c = .Find(KeyW(i), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Sheets("Satellite").Range("b" & j).Value = Worksheets(1).Range("a" & c.Row).Value
Worksheets(1).Range(c.Address).Copy
Sheets("Satellite").Activate
Range("a" & j).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Range("a" & j).Select
WordPos = 1
StartPos = 1
SearchStr = KeyW(i)
While WordPos <> 0
WordPos = InStr(StartPos + 1, Range("a" & j).Value, SearchStr, 1)
If WordPos > 0 _
Then
With ActiveCell.Characters(Start:=WordPos, Length:=Len(SearchStr)).Font
.FontStyle = "Bold"
.Color = -16727809
End With
StartPos = WordPos
End If
Wend
Worksheets(1).Activate
j = j + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Next i

Answer 1

I'd start by splitting out some of the logic into standalone methods, and calling them from your main code: this makes it easier to see what's going on and allows some re-use of your code later on.
For example:
Sub sort()
Dim wb As Workbook
Dim txt As String, allCells As Collection, c As Range, w As Range, rngDest As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set wb = ThisWorkbook
'(removed sheet selection code - not needed here)
Set rngDest = wb.Worksheets("Satellite").Range("A2") 'start listing matches here
For Each w In wb.Worksheets("MAIN").Range("N5:N15").Cells 'loop over possible search terms
txt = Trim(w.Value)
If Len(txt) > 0 Then
Set allCells = FindAll(wb.Worksheets(1).Range("c4:e7000"), txt) 'get all matches
For Each c In allCells
c.Copy rngDest 'copy matched cell
BoldWord rngDest, txt 'bold matched text
rngDest.Offset(0, 1) = _
c.EntireRow.Columns("A").Value 'copy colA from matched cell
Set rngDest = rngDest.Offset(1) 'next result row
Next c
End If
Next w
End Sub
'return a Collection of all cells in `rng` which contain `txt`
Public Function FindAll(rng As Range, txt As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=txt, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
'Bold all instances of `wrd` in cell `c`
Sub BoldWord(c As Range, txt As String)
Dim pos As Long, start As Long
start = 1
Do
pos = InStr(start, c.Value, txt, vbTextCompare)
If pos = 0 Then Exit Do
With c.Characters(pos, Len(txt))
.Font.Bold = True
.Font.Color = vbRed
End With
start = pos + Len(txt)
Loop
End Sub