VBA मॉड्यूल में निम्न कोड डालें।
Sub highlightWords()
Application.ScreenUpdating = False
Dim rng2HL As Range, rngCheck As Range, dictWords As Object
Dim a() As Variant, b() As Variant, wordlist As Variant, wordStart As Long
Set r = Selection
'Change the addresses below to match your data.
Set rng2HL = Range("A1:A9")
Set rngCheck = Range("B1:B9")
a = rng2HL.Value
b = rngCheck.Value
Set dictWords = CreateObject("Scripting.Dictionary")
'Load unique words from second column into a dictionary for easy checking
For i = LBound(b, 1) To UBound(b, 1)
wordlist = Split(b(i, 1), " ")
For j = LBound(wordlist) To UBound(wordlist)
If Not dictWords.Exists(wordlist(j)) Then
dictWords.Add wordlist(j), wordlist(j)
End If
Next j
Next i
'Reset range to highlight to all black font.
rng2HL.Font.ColorIndex = 1
'Check words one by one against dictionary.
For i = LBound(a, 1) To UBound(a, 1)
wordlist = Split(a(i, 1), " ")
For j = LBound(wordlist) To UBound(wordlist)
If Not dictWords.Exists(wordlist(j)) Then
wordStart = InStr(a(i, 1), wordlist(j))
'Change font color of word to red.
rng2HL.Cells(i).Characters(wordStart, Len(wordlist(j))).Font.ColorIndex = 3
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
बस अपनी कार्यपत्रक से मिलान करने के लिए नीचे की पंक्तियों में पते बदलना सुनिश्चित करें।
Set rng2HL = Range("A1:A9")
Set rngCheck = Range("B1:B9")
परिणाम:
संपादित करें:
चूंकि आपने नीचे टिप्पणियों में आवश्यकताएं जोड़ी हैं, इसलिए मैंने कॉलम सी में लाल-हाइलाइट किए गए वाक्यांशों की सूची को प्रिंट करने के लिए कोड को भी संशोधित किया है। यदि आप इस सूची को कहीं और चाहते हैं, तो आपको कोड के अंतिम भाग में पता समायोजित करना होगा। । मैंने हाइलाइटिंग कोड में भी सुधार किया - मैंने देखा कि यह अजीब चीजें करेगा जैसे केवल गैर-मिलान शब्द के पहले उदाहरण को उजागर करें।
Sub highlightWords()
Application.ScreenUpdating = False
Dim rng2HL As Range, rngCheck As Range, dictWords As Object, dictRed As Object
Dim a() As Variant, b() As Variant, wordlist As Variant, wordStart As Long, phraseLen As Integer
Dim re As Object, consec As Integer, tmpPhrase As String
'Change the addresses below to match your data.
Set rng2HL = Range("A1:A9")
Set rngCheck = Range("B1:B9")
a = rng2HL.Value
b = rngCheck.Value
Set dictWords = CreateObject("Scripting.Dictionary")
'Load unique words from second column into a dictionary for easy checking
For i = LBound(b, 1) To UBound(b, 1)
wordlist = Split(b(i, 1), " ")
For j = LBound(wordlist) To UBound(wordlist)
If Not dictWords.Exists(wordlist(j)) Then
dictWords.Add wordlist(j), wordlist(j)
End If
Next j
Next i
Erase b
'Reset range to highlight to all black font.
rng2HL.Font.ColorIndex = 1
Set dictRed = CreateObject("Scripting.Dictionary")
Set re = CreateObject("vbscript.regexp")
'Check words one by one against dictionary.
For i = LBound(a, 1) To UBound(a, 1)
wordlist = Split(a(i, 1), " ")
consec = 0
tmpPhrase = ""
For j = LBound(wordlist) To UBound(wordlist)
If Not dictWords.Exists(wordlist(j)) Then
consec = consec + 1
If consec > 1 Then tmpPhrase = tmpPhrase & " "
tmpPhrase = tmpPhrase & wordlist(j)
Else
If consec > 0 Then
If Not dictRed.Exists(tmpPhrase) Then dictRed.Add tmpPhrase, tmpPhrase
re.Pattern = "(^| )" & tmpPhrase & "( |$)"
Set matches = re.Execute(a(i, 1))
For Each m In matches
wordStart = m.FirstIndex
phraseLen = m.Length
'Change font color of word to red.
rng2HL.Cells(i).Characters(wordStart + 1, phraseLen).Font.ColorIndex = 3
Next m
consec = 0
tmpPhrase = ""
End If
End If
Next j
'Highlight any matches that appear at the end of the line
If consec > 0 Then
If Not dictRed.Exists(tmpPhrase) Then dictRed.Add tmpPhrase, tmpPhrase
re.Pattern = "(^" & tmpPhrase & "| " & tmpPhrase & ")( |$)"
Set matches = re.Execute(a(i, 1))
For Each m In matches
wordStart = m.FirstIndex
phraseLen = m.Length
'Change font color of word to red.
rng2HL.Cells(i).Characters(wordStart + 1, phraseLen).Font.ColorIndex = 3
Next m
End If
Next i
Erase a
'Output list of unique red phrases to column C.
redkeys = dictRed.Keys
For k = LBound(redkeys) To UBound(redkeys)
Range("C1").Offset(k, 0).Value = redkeys(k)
Next k
Erase redkeys
Application.ScreenUpdating = True
End Sub
