See next code and adjust const to your need.
Pay attention to the Reputation if you are please.
Option Explicit
Sub Check()
Const InWsName = "List"
Const DataWsName = "Data"
Const SC = "D" ' Search Column
Const TC = "S" ' Test Column
Dim Rg As Range
Dim WV As String
Dim F As Range
Dim NbT As Integer
Dim FAdd As String
Dim TOff As Integer ' Test Offset from Search column
TOff = Cells(1, TC).Column - Cells(1, SC).Column
For Each Rg In Range(Sheets(InWsName).Cells(1, SC), Sheets(InWsName).Cells(Rows.Count, SC).End(3))
Rg.Offset(0, TOff) = ""
WV = Trim(Rg)
NbT = 0
With Sheets(DataWsName)
Set F = .Cells.Find(What:=WV, After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
If (Not F Is Nothing) Then
FAdd = F.Address
Do
NbT = NbT + 1
Set F = .Cells.Find(What:=WV, After:=F, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
Loop While FAdd <> F.Address
Rg.Offset(0, TOff) = NbT
End If
End With
Next Rg
MsgBox ("Job Done")
End Sub
Bookmarks