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
_{Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du}
^{ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.}

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

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 http://www.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
_{Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du}
^{ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.}

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

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
_{Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du}
^{ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.}

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

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

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 http://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

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

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

hey malSchaun...

vielen lieben Dank für die Bemühungen...
das Programm läuft einwandfrei und befriedigt meine Bedürfnisse...

und sry das ich mich jez erst bedanke aba lange nicht da...

also nochmals vielen Dank und weiter so ;)

LG
MurderMo

hi all ^^

ein beispiel

gruss nighty

Option Explicit
Sub FilterKopieren()
    ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).Copy Worksheets(1).Range("C1")
    ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace
End Sub