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.
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.
Please also mark the comments that contributed to the solution of the article
Content-Key: 312822
Url: https://administrator.de/contentid/312822
Printed on: May 8, 2024 at 02:05 o'clock
5 Comments
Latest comment
Hi, check this:
Regards
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
You wrote in your first post:
Results in:
bzw. Leere Zellen löscht
so i implemented this in the above code ! 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
Then i missunderstood this
But i can write you another version which manually checks for duplicates instead of using the worksheetfunction.
Works a 100%!
bzw. Leere Zellen löscht
The Google Translator translates my above post incorrect.
I don't need google translator , only my german writing is bad not my understanding 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