使用VBA在Excel中查找關鍵字

我正在處理的檔案是從所有評論中選擇選定的單詞，為它們著色并將它們隔離到專用選項卡中。

所有關鍵字都已編碼到宏本身中。我不想將關鍵字寫入宏，而是告訴宏關鍵字位于 Excel 作業表中的陣列中，以便每個人都可以根據需要使用該檔案。

當我對陣列的關鍵字進行以下更改時，我在螢屏截圖上遇到錯誤，我不知道為什么。

衛星：

KeyW = Array("Satellite", "image", "blacks out", "resolution")

衛星：

KeyW = Array(Worksheets("MAIN").Range("N5:N15"))

下面的代碼不是我寫的。我只是做了一些修改。

我得到的錯誤：

運行時錯誤 13，型別不匹配

當我點擊除錯它顯示這條黃線

    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

uj5u.com熱心網友回復：

我首先將一些邏輯拆分為獨立的方法，然后從您的主代碼中呼叫它們：這樣可以更容易地查看正在發生的事情，并允許稍后重用您的代碼。

例如：

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

標籤：擅长 vba

上一篇：列[i-1]的VBA中的For回圈

下一篇：CATIA使用DXF轉換生成文本。規模問題