Sub ki136()
Dim actv As Object
Dim i As Integer, endr1 As Integer, endr2 As Integer
Dim keym As String

Application.ScreenUpdating = False
 Sheets("Sheet1").Select
 Range("A1").Select
 Selection.End(xlDown).Select
 endr1 = ActiveCell.Row
 
 Range("B1").Select
 Selection.End(xlDown).Select
 endr2 = ActiveCell.Row
 
    c1 = 1: c2 = 1
For i = 1 To endr1
    keym = Cells(i, 1)
    
    Set actv = Range(Cells(1, 1), Cells(endr2, 1)) _
     .find(keym, , , xlWhole, xlByColumns, xlNext, False)
    If actv Is Nothing Then
          Cells(c2, 6) = keym
          c2 = c2 + 1
    Else
          Cells(c1, 4) = keym
          c1 = c1 + 1
    End If
Next
End Sub

Sub ki136a()
    Sheets("Sheet1").Select
    Columns("D:D").Select
    Selection.ClearContents
    Columns("F:F").Select
    Selection.ClearContents
    Range("C1").Select
    Sheets("Title").Select
End Sub