Excel 2013 Duplikate löschen und Startzeile ermitteln VBA

Servus miteinander,

ich bräuchte einen VBA Code der in 7 verschiedenen Spalten die Duplikate rauslöscht aber nicht Leere Zeilen bzw. Leere Zellen löscht.
Der Code soll auch nur die Duplikate je Spalte löschen. Er soll also nicht die Daten von Spalte A mit B vergleichen und löschen sondern nur Spaltenweise vorgehen.

Folgender Code funktioniert eigentlich ganz gut aber wenn ich es überprüfe funktioniert es nicht zu 100%. Alle Spalten sind aber gleich Formatiert...
Die Tabelle sieht so aus das in jeder Zeile nur eine Zelle Daten enthält.

ActiveSheet.Range("$A$1:$J$5000").RemoveDuplicates Columns:=Array(4, 5, 6, 7, 8, 9, _
10), Header:=xlYes

Weiterhin muss ich eine Startzelle ermitteln. Um die Startzelle zu ermittelnt müsste der Code Spalte 4 bis 10 durchgehen und die höchste ermittelte Zeile ausgeben.
Zur Veranschaulichung:

Dieser Code ermittelt mir ja die erste freie Zelle aus Spalte A
a = Range("A65536").End(xlUp).Offset(1, 0).Select
nehmen wir an a = Zeile 6

Dieser Code ermittelt mir ja die erste freie Zelle aus Spalte B
b = Range("B65536").End(xlUp).Offset(1, 0).Select
nehmen wir an b = Zeile 15

Dieser Code ermittelt mir ja die erste freie Zelle aus Spalte C
c = Range("C65536").End(xlUp).Offset(1, 0).Select
nehmen wir an c = Zeile 8

Dann sollte der Code Zeile 15 als nächste freie Zeile ausgeben.
Danke für eure Hilfe.

Sub RemoveDuplicates()
    Dim lngFreeRow As Long, colFreeRow as Long
    With ActiveSheet
        For i = 4 To 10
            .Columns(i).RemoveDuplicates Columns:=Array(1), Header:=xlYes
            DeleteEmptyCells .Range(.Cells(1, i), .Cells(.Cells(Rows.Count, i).End(xlUp).Row, i))
            colFreeRow = .Cells(Rows.Count, i).End(xlUp).Row + 1
            If colFreeRow > lngFreeRow Then lngFreeRow = colFreeRow
        Next
    End With
    MsgBox "The next free row over all columns has number " & lngFreeRow, vbInformation  
End Sub

Sub DeleteEmptyCells(rngCells As Range)
    Dim rngDel As Range
    For Each cell In rngCells
        If cell.Value = "" Then  
            If Not rngDel Is Nothing Then
                Set rngDel = Union(rngDel, cell)
            Else
                Set rngDel = cell
            End If
        End If
    Next
    If Not rngDel Is Nothing Then rngDel.Delete
End Sub

Sub RemoveDuplicates()
    Dim lngFreeRow As Long, colFreeRow as Long
    With ActiveSheet
        For i = 4 To 10
            .Columns(i).RemoveDuplicates Columns:=Array(1), Header:=xlYes
            colFreeRow = .Cells(Rows.Count, i).End(xlUp).Row + 1
            If colFreeRow > lngFreeRow Then lngFreeRow = colFreeRow
        Next
    End With
    MsgBox "The next free row over all columns has number " & lngFreeRow, vbInformation  
End Sub

Sub RemoveDuplicates()
    Dim lngFreeRow As Long, colFreeRow As Long, cell As Range, dic as Object, i as Long
    Set dic = CreateObject("scripting.dictionary")  
    With ActiveSheet
        For i = 4 To 10
            dic.RemoveAll
            For Each cell In .Range(.Cells(2, i), .Cells(Rows.Count, i).End(xlUp))
                If cell.Value <> "" Then  
                    If dic.exists(cell.Value) Then
                        cell.Delete xlShiftUp
                    Else
                        dic.Add cell.Value, ""  
                    End If
                End If
            Next
            colFreeRow = .Cells(Rows.Count, i).End(xlUp).Row + 1
            If colFreeRow > lngFreeRow Then lngFreeRow = colFreeRow
        Next
    End With
    MsgBox "The next free row over all columns has number " & lngFreeRow, vbInformation  
End Sub