Sub check()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("History")
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Result")
Dim i As Long, j As Integer, k As Integer
i = 2
j = 0
k = 1
Do While ws.Cells(i, 3).Value <> ""
If ws.Cells(i, 3).Value = ws.Cells(i - 1, 3).Value Then
j = j + 1
Else
j = 0
End If
If j > 1 Then
ws2.Cells(k, 1).Value = ws.Cells(i, 3).Value
k = k + 1
End If
i = i + 1
Loop
Sheets("Result").Select
Columns("A:A").Select
' delete duplicate data
ActiveSheet.Range("$A$1:$A$5000").RemoveDuplicates Columns:=1, Header:=xlNo
MsgBox "End"
End Sub