Saya membuat daftar kata kunci yang terkait dengan materi pelajaran yang perlu saya teliti dari daftar umpan balik survei.

Saya ingin menyoroti kata kunci dalam survei.

Saya menemukan makro ini. Ini memiliki kelemahan.

  1. Mengharuskan saya terus menjalankan makro dan kemudian mengetikkan string teks dari daftar kata kunci saya.
  2. Peka huruf besar/kecil, yang berpotensi menggandakan jumlah waktu yang diperlukan untuk menjalankan semua kata di daftar kunci saya.
Sub HighlightStrings()
'Updateby Extendoffice 20160704
Application.ScreenUpdating = False
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
cFnd = InputBox("Enter the text string to highlight")
y = Len(cFnd)
For Each Rng In Selection
    With Rng
        m = UBound(Split(Rng.Value, cFnd))
        If m > 0 Then
            xTmp = ""
            For x = 0 To m - 1
                xTmp = xTmp & Split(Rng.Value, cFnd)(x)
                .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
                xTmp = xTmp & cFnd
            Next
        End If
    End With
Next Rng
Application.ScreenUpdating = True
End Sub
0
Mintchip 18 April 2020, 00:36

1 menjawab

Jawaban Terbaik

Coba kode ini

Sub Highlight_Text_Strings()
Dim rng As Range, c As Range, cl As Range, cFnd As String, v As String, xTmp As String, xColor As Long, x As Long, m As Long

Application.ScreenUpdating = False
    Set rng = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
    rng.Font.ColorIndex = 0: xColor = 3

    For Each c In Sheet1.Range("H1:H3")     'Keywords List
        cFnd = UCase(c.Value)
        For Each cl In rng
            v = UCase(cl.Value)
            With cl
                m = UBound(Split(v, cFnd))
                If m > 0 Then
                    xTmp = ""
                    For x = 0 To m - 1
                        xTmp = xTmp & Split(v, cFnd)(x)
                        .Characters(Start:=Len(xTmp) + 1, Length:=Len(cFnd)).Font.ColorIndex = xColor

                        xTmp = xTmp & cFnd
                    Next x
                End If
            End With
        Next cl
        xColor = xColor + 1
    Next c
Application.ScreenUpdating = True
End Sub

enter image description here

0
YasserKhalil 17 April 2020, 23:13