The College Student Blog

Sub SortRootKeywords()

Range(”I1″, “I10000″).ClearContents

Dim FindAddress As String
Dim R As Range, Root As String, WCRoot, Col As Integer, Row As Integer

Root = InputBox(”Please Enter Root Keyword.”, “Keyword Entry!”)
WCRoot = “*” & Root & “*”
If “” = Root Then

Exit Sub
Else

‘******************************************************************************************************************************

Dim Z As Range, FindAddressZ As String, Counter As Integer

‘Set the range in which we want to search in
With Range(”A1:I10000″)
‘Search for the first occurrence of the item
Set Z = .Find(WCRoot)
‘If a match is found then
If Not Z Is Nothing Then
‘Store the address of the cell where the first match is found in a variable
FindAddressZ = Z.Address
Do

Counter = Counter + 1
‘Search for the next cell with a matching value
Set Z = .FindNext(Z)
‘Search for all the other occurrences of the item i.e.
‘Loop as long matches are found, and the address of the cell where a match is found,
‘is different from the address of the cell where the first match is found (FindAddress)
Loop While Not Z Is Nothing And Z.Address <> FindAddressZ
End If
End With

‘******************************************************************************************************************************

Dim Lawl As String
Dim DeleteAddress As String

Col = 9

‘Set the range in which we want to search in
With Range(”A1:A10000″)
‘Search for the first occurrence of the item
Set R = .Find(WCRoot)
‘If a match is found then
If Not R Is Nothing Then
‘Store the address of the cell where the first match is found in a variable
FindAddress = R.Address
Do

For Row = 1 To Counter

‘Color the cell where a match is found yellow
Cells(Row, Col) = R
DeleteAddress = R.Address
Range(DeleteAddress) = Lawl
‘Search for the next cell with a matching value
Set R = .FindNext(R)
‘Search for all the other occurrences of the item i.e.
‘Loop as long matches are found, and the address of the cell where a match is found,
‘is different from the address of the cell where the first match is found (FindAddress)

Next Row

If R Is Nothing Then
Exit Sub
End If

Loop While Not R Is Nothing And R.Address <> FindAddress

End If
End With

‘Clear memory
Set R = Nothing

End If

End Sub