Guten Abend
Bei meinem Code
Sub Doppelte_Loeschen()
werden die "Doppelten" nur gelöscht, wenn auch die Tabelle "Auswertung" ausgewählt ist. Wenn _
eine andere Tabelle ausgewählt ist, wenn der Code abläuft, funktioniert das Löschen nicht.
Ich vermute, dass die Referenzierung bei der Zeile
'bei dieser Formel bleibt ein Null-Wert, sofern vorhanden
.FormulaR1C1 = "=IF(EXACT(RC[" & SP & "],R[-1]C[" & SP & "]),TRUE,RC[-1])"
nicht vollständig ist. Ich habe es jedoch nicht geschafft, diese zu ergänzen.
Wer kann mir helfen?
Gruss, Peter
With Sheets("Auswertung")
With .Range(.Cells(Z1, 2), .Cells(Z2, 2))
.EntireRow.Sort Key1:=Cells(Z1, SP + 2), Order1:=xlAscending, Header:=xlNo
''.FormulaR1C1 = "=IF(RC[" & SP & "]=R[-1]C[" & SP & "],TRUE,RC[-1])" 'bei dieser _
Formel fliegen alle Null Werte raus
.FormulaR1C1 = "=IF(EXACT(RC[" & SP & "],R[-1]C[" & SP & "]),TRUE,RC[-1])" 'bei dieser _
Formel bleibt ein Null-Wert, sofern vorhanden
.Formula = .Value
.EntireRow.Sort Key1:=Cells(Z1, 2), Order1:=xlAscending, Header:=xlNo
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
End With
Sub Doppelte_Loeschen()
Dim Z1 As Long, Z2 As Long, SP As Long, c As Range, Ende As Long, lngSpa As Long, Bereich As _
Range
Z1 = Range("psaBeginn").Row
Z2 = Range("psaEnde").Row
SP = Range("psaBeginn").Column
'--- Hilfsspalten einfügen und Original-Reihenfolge sichern
With Sheets("Auswertung")
.Range("A:B").Insert
With .Range(.Cells(Z1, 1), .Cells(Z2, 1))
.FormulaR1C1 = "=Row()"
.Formula = .Value
End With
End With
'--- Doppelte kennzeichnen und loeschen
On Error Resume Next
With Sheets("Auswertung")
With .Range(.Cells(Z1, 2), .Cells(Z2, 2))
.EntireRow.Sort Key1:=Cells(Z1, SP + 2), Order1:=xlAscending, Header:=xlNo
''.FormulaR1C1 = "=IF(RC[" & SP & "]=R[-1]C[" & SP & "],TRUE,RC[-1])" 'bei dieser _
Formel fliegen alle Null Werte raus
.FormulaR1C1 = "=IF(EXACT(RC[" & SP & "],R[-1]C[" & SP & "]),TRUE,RC[-1])" 'bei dieser _
Formel bleibt ein Null-Wert, sofern vorhanden
.Formula = .Value
.EntireRow.Sort Key1:=Cells(Z1, 2), Order1:=xlAscending, Header:=xlNo
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
End With
On Error GoTo 0
'--- Aufräumen
Sheets("Auswertung").Range("A:B").Delete
'alle Adressnummern benennen (da möglicherweise durch das loeschen das "Ende" eliminiert _
wurde
Ende = Sheets("Auswertung").Cells(65536, 1).End(xlUp).Row
Ende = WorksheetFunction.Max(Ende, 5)
Set Bereich = Worksheets("Auswertung").Range("A" & Range("psaBeginn").Row, "A" & Ende)
ActiveWorkbook.Names.Add _
Name:="psAdressen", _
RefersTo:=Bereich, Visible:=True
'letzte Zelle benennen
Set Bereich = Worksheets("Auswertung").Range("A" & Ende, "A" & Ende)
ActiveWorkbook.Names.Add _
Name:="psaEnde", _
RefersTo:=Bereich, Visible:=True
End Sub