こんな感じでどうでしょう｡

Sub hoge()
 Dim cnt, t, n, r0, r1 As Long
 Dim rr(9999) As Long  '最大行数分用意してください
 n = Range("C1").End(xlDown).Row
 For r0 = 1 To n
  'ﾜｰｸ変数の初期化
 For r1 = 0 To n
 rr(r1) = 0
 Next r1
  'より下に重複要素があるか検査
 cnt = 0
 t = 1
 For r1 = r0 To n
 If Cells(r0, 3).Value = Cells(r1, 3).Value Then
 cnt = cnt + 1
 If Cells(r1, 1) <> "KIT" Then
 rr(t) = r1
 t = t + 1
 End If
 End If
 Next r1
 If (cnt > 1) Then
 For r1 = 1 To t
 If (rr(r1) > 0) Then
 Cells(rr(r1), 5).Value = "ﾍﾞｰｽ"
 End If
 Next r1
 End If
 Next r0
End Sub

一般関数でも求められると思いますが､一応ﾏｸﾛにしました｡

.Value = .Value

の部分を削除するれば数式の状態が見れますので､確認できるかと思います｡

補足ですがこのﾏｸﾛでしたら､ﾌｨﾙﾀで表示されている部分だけが

対象となりますので､このまま使用できます｡

40000行のﾃﾞｰﾀで試してみましたが､そのままでも20秒ほどで結果が出ました｡

関数の利用はﾏｸﾛより遅いと思われるかもしれませんが､Find や Sum

などはﾏｸﾛよりもはるかに高速です｡

内容にもよりますが､ﾏｸﾛでやるにしてもﾏｸﾛから関数を利用した方が

ｼﾝﾌﾟﾙで高速に処理できるｹｰｽは結構多いです｡

VBA高速化ﾃｸﾆｯｸ ? 関数も使え！ ?

Sub CheckBase()
 Dim lastRow As Long
 lastRow = Cells(Rows.Count, "D").End(xlUp).Row
 With Range("H2:H" & lastRow)
 .FormulaR1C1 = "=IF(AND(COUNTIF(R2C4:R" & lastRow & "C4,RC4)>=2,RC1<>""KIT""),""ﾍﾞｰｽ"","""")"
 .Value = .Value
 End With
End Sub

ｺﾒﾝﾄへの対応しました｡

R が行､Cが列になります｡

普通ならば 数式を ｾﾙに貼り付ければ 一発なんですけどね｡

=IF(A2="KIT","",IF(COUNTIF(D:D,"=" & D2)>1,"ﾍﾞｰｽ",""))

これを H2に貼り付けて､それをｺﾋﾟｰして H3以降に貼り付ければいいだけです｡

でも それをしたくないならば 多少は 時間がかかりますが

Sub main()
 Dim c As String
 Dim a As Long
 Application.ScreenUpdating = False
 For a = 2 To Range("A1").End(xlDown).Row
 If Cells(a, "A") <> "KIT" Then
 If Application.WorksheetFunction.CountIf(Range("D:D"), "=" & Cells(a, "D")) > 1 Then Cells(a, "H") = "ﾍﾞｰｽ"
 End If
 Next a
 Application.ScreenUpdating = True
End Sub

とやるしかないでしょう｡

追記

列の変更をしました｡