Duplikate mit Bedingung durch Makro entfernen

299 Aufrufe
Gefragt 18, Apr 2017 in Tabellenkalkulation von Sunnykind
Ich habe eine Tabelle in der die Werte der Spalte A durch eine Formel von einer anderen Tabelle übernommen werden, sobald dort ein Wert hinterlegt wird.
Wenn ich nun in meiner Tabelle Duplikate der Spalte A entfernen will um doppelte Werte zu löschen, sind auch die hinterlegten Formeln weg.
Wie kann ich in ein Makro einbauen, dass die Werte nur gelöscht werden, wenn dort ein Wert (in dem Fall eine 4 stellige ID-Nummer) hinterlegt ist.

8 Antworten

0 Punkte
Beantwortet 18, Apr 2017 von Nighty__
Hallo Sunnykind .-)

Formeln sind nicht so sehr mein gebiet .-)
Ich kann dir daher nur das anbieten!
Vielleicht reicht es Ja ^^
Daten ohne Doppelte/Nullwerte

Gruss Nighty

Quelle
6 Zeile Worksheetname anpassen
Spalte A wirde erfasst,gegebenenfalls anpassen

Ziel
10 Zeile Worksheetname anpassen
Ausgabe Spalte B,gegebenenfalls anpassen

Sub KeineDoppelten()
Call EventsOff
Dim DeinArr As Variant
Dim objDic As Object
Dim ZeilenIndex As Long
Set objDic = CreateObject("scripting.dictionary")
DeinArr = Worksheets("Tabelle1").Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
For ZeilenIndex = 1 To UBound(DeinArr)
If DeinArr(ZeilenIndex, 1) > 0 Then objDic(DeinArr(ZeilenIndex, 1)) = 1
Next
Worksheets("Tabelle1").Range("B2").Resize(objDic.Count) = WorksheetFunction.Transpose(objDic.keys)
Set objDic = Nothing
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
0 Punkte
Beantwortet 18, Apr 2017 von Nighty__
Hallo Community .-)

Der Spezialfilter(Kopie nur sichtbare Zellen) ist natürlich um längen schneller,doch er behandelt keine Nullwerte!

Gruss Nighty
0 Punkte
Beantwortet 18, Apr 2017 von Nighty__
Hallo Sunnykind .-)

Hab da noch andere Ideen!
Sind die Formeln alle gleich?
Poste mal 2 aufeinanderfolgende Formeln
Vielleicht können wir auch die Formeln zurückkopieren

Gruss Nighty
0 Punkte
Beantwortet 18, Apr 2017 von Sunnykind
Hallo Nighty,
danke für deine Antwort. Leider ist es nicht das was ich brauche.

Ich versuche es mal anders zu erklären.

Tabelle 1

A B C D
ID Datum Abschluss Vertrag Anzahl Besuche
1001 09.01.2017 ja 2
1002 12.02.2017 nein 1
1001 13.05.2017 ja 2
Formel Formel Formel Formel


In Tabelle 2 liegen die Werte für die Formeln. Dort will ich nichts ändern.

Ich möchte nun per Makro in Tabelle (Spalte A) alle Zeilen auf doppelte Werte durchsuchen und die entsprechende Zeile löschen.
Mein Problem ist, dass in den noch nicht gefüllten Zeilen Formeln hinterlegt sind. Diese werden bei mir auch als doppelte Werte erkannt und die Zeilen werden auch gelöscht.

Die Formeln in Spalte A: ='Daten Besuche'!A9
D: = =SUMMENPRODUKT(('Daten Besuche'!A:A=A23)*('Daten Besuche'!D:D="Besuch"))
0 Punkte
Beantwortet 18, Apr 2017 von Nighty__
Hallo Sunnykind .-)

Muss ich mir Gedanken darüber machen,sollte ja auch schnell sein!

Gruss Nighty
0 Punkte
Beantwortet 19, Apr 2017 von Nighty__
Hallo Sunnykind .-)

Über Cells zugriffe einfach, aber zu langsam!

Ich glaub ich hab da schon einige Ideen,gib mir noch bisl zeit

Gruss Nighty
0 Punkte
Beantwortet 20, Apr 2017 von Nighty__
Hallo Sunnykind .-)

Die Dic Object Idee scheiterte an meiner alten Excel Version!
Dann eine andere Idee .-)

Gruss Nighty

Probier mal!

Vorraussetzung
Keine Nullwerte,keine leeren Zellen
Formeln ohne Werte müssen 0 zurückgeben,somit können die Formeln schnell lokalisiert werden

Wenn es so machbar ist für Dich .-)

Sub KeineDoppelten()
Dim Afilter As Object, Sfilter As Object, Delfilter As Object
Worksheets("Tabelle1").Range("A1").AutoFilter Field:=1, Criteria1:="<1"
Worksheets("Tabelle1").Rows(1).Hidden = True
Set Afilter = Worksheets("Tabelle1").AutoFilter.Range.SpecialCells(xlCellTypeVisible)
Worksheets("Tabelle1").Range("A1").AutoFilter
Afilter.EntireRow.Hidden = True
Worksheets("Tabelle1").Columns("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set Sfilter = Worksheets(1).Cells.SpecialCells(xlCellTypeVisible)
Worksheets("Tabelle1").Columns("A:A").AdvancedFilter Action:=xlFilterInPlace, Unique:=False
Afilter.Rows.Hidden = True
Sfilter.Rows.Hidden = True
Set Delfilter = Worksheets("Tabelle1").Cells.SpecialCells(xlCellTypeVisible)
Afilter.Rows.Hidden = False
Sfilter.Rows.Hidden = False
Delfilter.Delete Shift:=xlUp
Set Afilter = Nothing
Set Sfilter = Nothing
Set Delfilter = Nothing
End Sub
0 Punkte
Beantwortet 20, Apr 2017 von Nighty__
Hallo Sunnykind .-)
Statt Rückgabewert einer Formel=0
Ginge auch Rückgabewert einer Formel=False
Falls es dir besser passen würde .-)

Ersetze die dritte Zeile
Worksheets("Tabelle1").Range("A1").AutoFilter Field:=1, Criteria1:="<1"

Durch
Worksheets("Tabelle1").Range("A1").AutoFilter Field:=1, Criteria1:=False


Gruss Nighty
...