alexiot
Goto Top

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.

Content-Key: 312822

Url: https://administrator.de/contentid/312822

Ausgedruckt am: 19.03.2024 um 14:03 Uhr

Mitglied: 129813
129813 17.08.2016 aktualisiert um 08:35:44 Uhr
Goto Top
Hi, check this:
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
Regards
Mitglied: AlexIOT
AlexIOT 19.08.2016 um 03:35:31 Uhr
Goto Top
Funktioniert leider nicht.
Ausgangspositon:

Nach deinem Skript sieht das ganze so aus:

Aber ich will es so haben:

Sprich, Zeilen die vorher leer waren, sollen auch leer bleiben.
Danke für deine Hilfe.
vorher
soll
nachher
Mitglied: 129813
129813 19.08.2016 aktualisiert um 12:11:30 Uhr
Goto Top
You wrote in your first post:
bzw. Leere Zellen löscht
so i implemented this in the above code face-smile! But changing that is no problem, simply remove the line with the call to remove empty cells > remove Line 6 And the Sub Sub DeleteEmptyCells(rngCells As Range) is also obsolete in this case.

Results in:
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
Mitglied: AlexIOT
AlexIOT 19.08.2016 um 19:37:37 Uhr
Goto Top
In my first post I wrote: don't delete empty rows or cells. The Google Translator translates my above post incorrect.
Thank you for your reply but unfortunately It does not work....
Mitglied: 129813
Lösung 129813 19.08.2016 aktualisiert um 19:54:30 Uhr
Goto Top
Zitat von @AlexIOT:
In my first post I wrote: don't delete empty rows or cells.
Then i missunderstood this
bzw. Leere Zellen löscht

The Google Translator translates my above post incorrect.
I don't need google translator face-wink, only my german writing is bad not my understanding face-smile
Thank you for your reply but unfortunately It does not work....
Here it does what it should, sorry.

But i can write you another version which manually checks for duplicates instead of using the worksheetfunction.
Works a 100%!
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