使用 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