Doppelte Einträge finden und seperat ausgeben

Question

Halle alle zusammen,

ich habe eine Tabelle mit 3 Spalten und mehr als 4000 Zeilen.
Ich brauche ein Programm, welches alle doppelten bzw. mehrmaligen Einträge aus Spalte 1 sucht, ausschneidet und irgendwo in Tabelle2 einfügt.
Leider bekomme ich das nicht hin.
Ich hoffe mir kann schnell jemand helfen.
Vielen Dank im Voraus.

MfG MurderMo

Answer 1

Hallo MurderMo,

bitte bemühe doch mal die Forumssuche oben rechts. Dieses Thema wird hier mehrmals in der Woche behandelt. Das sollte in der Suche auch etwas für Dich dabei sein. Gebe in das Suchenfeld einfach mal das Wort "doppelte" ein und Du wirst sehen, wieviele Ergebnisse Du zu dem Thema erhäslt.

Bei Fragen zu einer Lösung melde Dich.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 2

Danke für den Hinweis...
aba die Lösungsansätze helfen mir nur sehr bedingt weiter.
Ich habe schon so viele Foren nach der Lösung für mein Problem durchkemmt, aba finde keine Lösung.

Bei den jeweils behandelten Theman geht es immer nur darum, doppelte Einträge zu löschen, nicht aber darum, sie zu verschieben.

Ich hoffe auf dein Verständnis.

MfG MurderMo

Answer 3

Hallo MurderMo,

wenn ich wie in AW1 geschrieben in das Suchenfeld das Wort "doppelt" eintrage, erhalte ich eine ganze Menge Ergebnisse, bei der z.B. der 9. Eintrag das Ergebnis zu Deiner Frage liefert. Im Beitrag https://supportnet.de/t/2223532 wird genau das gleiche behandelt und auch eine Lösung findest Du dort.

Sorry, aber mir kommt es eher so vor, lass mal die anderen den Kopf über mein Problem zerbrechen, als wenn ich das selber machen muss.

MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 4

Ich kann dich leider nicht bestätigen.

Dort geht es leider wieder nicht um VBA, was ich aber brauche.
Sonst hätte ich schon längst auf eine der vorhandenen Lösungen zurückgegriffen.

Ich frag ja nich ohne Grund nach Möglichkeiten für ein Programm.
Vielleicht weist du ja aba was.
Wäre echt nett.

Weil ich komm einfach nicht auf ne vernünftige Lösung.
Sonst würd ich wohl kaum fragen.

Danke im Voraus

MurderMo

Answer 5

Hallo MurderMo,

wo steht, dass Du eine VBA-Lösung benötigst? Nirgends.

Du musst genauere Angaben machen denn wir wissen hier nicht, was Du möchtest. Wenn Du schreibst, Du willst doppelte Daten herausfiltern, dann bekommst Du eine Lösung die das macht. Wenn Du eine VBA-Lösung willst, dann musst Du das schon schreiben.

Ich mache mir mal Gedanken zu einer Lösung.


MfG,
Oliver
[sub]Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du[/sub]
[sup] ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.[/sup]

Answer 6

Hi,

Folgender Code wäre mein Ansatz für Dein Problem, so wie ich es aufgefasst habe.
Dabei werden doppelte Werte in der Tabelle1 SpalteA gesucht. Treffer werden nach Tabelle2 kopiert und anschliesend die Zeile in Tabelle1 komplett GELÖSCHT. So habe ich Dein "...sucht, ausschneidet und... " mal interpretiert.
btw.:Leere Zellen dürfen bei dieser Version im Wertebereich der SpalteA nicht vorhanden sein.

Sub MurderMo_Sort()
With Application
.EnableEvents = False 'Events abschalten
.ScreenUpdating = False 'Bildschirmaktualisierung abschalten
.Calculation = xlCalculationManual 'Berechnungsmodus auf Manuell
End With

'wenn Fehler gehe zum Ende
On Error GoTo ErrEnde

'Variablendeklaration
Dim shQuel As Worksheet, shZiel As Worksheet
Dim lngQLR As Long, lngZLR As Long, lngQR As Long
Dim lngCount As Long


'Tabellen benennen
With ThisWorkbook
Set shQuel = Sheets("Tabelle1")
Set shZiel = Sheets("Tabelle2")
End With


'letzte Reihe in Quelle
lngQLR = shQuel.Cells(Rows.Count, 1).End(xlUp).Row

'Quellreihen durlaufen
'Wenn Nummer in Quelltabelle mehrfach vorhanden
'Reihen rückwärts durchlaufen bei Gleichheit kopieren&löschen
For lngQR = 1 To lngQLR
If shQuel.Cells(lngQR, 1).Value = "" Then Exit For
If WorksheetFunction.CountIf(shQuel.Range("A:A"), shQuel.Cells(lngQR, 1).Value) > 1 Then
lngQLR = shQuel.Cells(Rows.Count, 1).End(xlUp).Row
For lngCount = lngQLR To lngQR + 1 Step -1
If shQuel.Cells(lngCount, 1).Value = shQuel.Cells(lngQR, 1).Value Then
lngZLR = shZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Range(shQuel.Cells(lngCount, 1), shQuel.Cells(lngCount, 3)).Copy
shZiel.Cells(lngZLR, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Range(shQuel.Cells(lngCount, 1), shQuel.Cells(lngCount, 3)).EntireRow.Delete
End If
Next
End If
Next

ErrEnde:
'Zwischenablage löschen
Application.CutCopyMode = False
'Verweise aufheben
Set shQuel = Nothing
Set shZiel = Nothing

With Application
.EnableEvents = True 'Events einschalten
.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
.Calculation = xlCalculationAutomatic 'Berechnungsmodus auf auto
.Calculate 'Mappen neu rechnen
End With
End Sub

Kopiere den Code in ein Standardmodul und starte ihn über eine Tastenkombination oder Befehlsschalfläche. (Funktionsprüfung bitte an einer Testdatei oder Sicherheitskopie.)

bye
malSchauen

Answer 7

Hey malSchauen...

dein Ansatz ist echt super und läuft auch einwandfrei bis auf ein Problem...

besteht die Möglichkeit alle Datensätze auszuschneiden und in der anderen Tabelle einzufügen?

weil momentan lässt er den "originalsatz" noch in tabelle 1 und übernimmt ihn nicht mit....

im prinzip müsste man da doch nur die bezüge ändern...
hab schon ein wenig probiert aba komm nicht auf die lösung...

Danke im Voraus...

mfg
MurderMo

Answer 8

Hi,

Sry, da werd ich so ohne Nachfrage nicht schlau draus.

Beispiel (Quelle_vorher)

SpalteA
1
2
3
4
1
2
3
5

Jetziges Ergebnis: Quelle_nachher

SpalteA
1
2
3
4
5

- InTabelle2 stehen danach (wenn vorher leer)

SpalteA
1
2
3

Wie stellst Du Dir das Ergebnis denn vor?
Evtl. machst Du einmal eine Beispielmappe (mit ein paar Beispieldaten). Darin dann die Tabellen "Quelldaten", "Quelldaten_danach" und "Zieldaten_danach". Diese Mappe kannst Du dann z.B. bei www.file-upload.net/ hochladen, und den DownloadLink, welchen Du dort im Anschluss erhälst, hier posten. Damit kann man sich dann evtl. ein besseres Bild von Deinen Wünschen machen.

Was ich mir aus AW7 als Ergebnis zusammenreime, würde dann so aussehen:

Quelle_danach

SpalteA
4
5

Ziel_danach

SpalteA
1
1
2
2
3
3

Aber ob das so passt?

bye
malSchauen

Answer 9

hey...

genaus so wie du es im letzten bsp schreibst soll es aussehen!

alles was doppelt ist, soll in die 2. tabelle...

ausgangstabelle sieht nämlich so aus, dass sich die spalten 2 und 3 unterscheiden. deswegen muss alles kopiert werden^^

beispiel:

Quelle

A B C

1 a ga
2 b jg
3 c kf
1 a ös
2 d af
3 a ga
4 f st
5 b kl

Ziel

A B C

1 a ga
2 b jg
3 c kf
1 a ös
2 d af
3 a ga


Quelle danach

A B C

4 f st
5 b kl

das programm müsste halt nur soweit geändert werden, dass alle in Spalte A identischen argumente in das ziel geschnitten werden...

das passt ja auch alles, nur das halt ein datensatz immer erhalten bleibt.

wäre super wenn du das hinbekommen würdest...
viele dank im voraus

mfg
MurderMo

Answer 10

Hi,

Ersetze den Code aus AW6 durch den folgenden:

Sub MurderMo_Sort2()
With Application
.EnableEvents = False 'Events abschalten
.ScreenUpdating = False 'Bildschirmaktualisierung abschalten
.Calculation = xlCalculationManual 'Berechnungsmodus auf Manuell
End With

'wenn Fehler gehe zum Ende
On Error GoTo ErrEnde

'Variablendeklaration
Dim shQuel As Worksheet, shZiel As Worksheet
Dim lngQLR As Long, lngZLR As Long, lngQR As Long
Dim lngCount1 As Long, lngKillCount As Long, lngCount2 As Long
Dim varScratch As Variant


'Tabellen benennen
With ThisWorkbook
Set shQuel = Sheets("Tabelle1")
Set shZiel = Sheets("Tabelle2")
End With


'letzte Reihe in Quelle
lngQLR = shQuel.Cells(Rows.Count, 1).End(xlUp).Row

'Quellreihen durlaufen
'Wenn Wert in Quelltabelle mehrfach vorhanden
'Treffer zählen
'Treffer suchen kopieren & Inhalt löschen
For lngCount1 = 1 To lngQLR Step 1
varScratch = shQuel.Cells(lngCount1, 1).Value
If WorksheetFunction.CountIf(shQuel.Range("A:A"), varScratch) > 1 Then
lngKillCount = WorksheetFunction.CountIf(shQuel.Range("A:A"), varScratch)
For lngCount2 = 1 To lngKillCount Step 1
If IsNumeric(varScratch) Then
lngQR = WorksheetFunction.Match(CDbl(varScratch), shQuel.Range("A:A"), 0)
Else
lngQR = WorksheetFunction.Match(varScratch, shQuel.Range("A:A"), 0)
End If
lngZLR = shZiel.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Range(shQuel.Cells(lngQR, 1), shQuel.Cells(lngQR, 3)).Copy
shZiel.Cells(lngZLR, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Range(shQuel.Cells(lngQR, 1), shQuel.Cells(lngQR, 3)).Clear
Next
End If
Next

'Leerzellen im ursprünglichen Quellbereich löschen
Range(shQuel.Rows(1), shQuel.Rows(lngQLR)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

ErrEnde:

'Zwischenablage löschen
Application.CutCopyMode = False

'Verweise aufheben
Set shQuel = Nothing
Set shZiel = Nothing

With Application
.EnableEvents = True 'Events einschalten
.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
.Calculation = xlCalculationAutomatic 'Berechnungsmodus auf auto
.Calculate 'Mappen neu rechnen
End With
End Sub

Das die Zieltabelle in SpalteA gleich blockweise die Treffer zusammenfasst, wird Dich sicher nicht stören, nehme ich mal an.

bye
malSchauen