Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1476to1480
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Ohne Duplikate kopieren...

Ohne Duplikate kopieren...
23.02.2016 19:20:46
Marvin
Guten Abend zusammen,
anbei direkt meine Datei zum Verständnis, bzw. nur der "Anfang" ohne alles.
https://www.herber.de/bbs/user/103823.xlsx
In der Datei befinden sich Spaltenüberschriften und darunter die Beispieldaten.
Die Daten werden immer pro Zeile erfasst von A nach J.
Die Datenerfassung beginnt ab A8.
Worum es mir geht, diese Tabelle bzw. die Zeilendaten sollen in Tabelle2 kopiert werden ohne jegliches Duplikat, dabei soll Tabelle1 so bestehen bleiben ohne jegliche Änderung.
Was mir wichtig ist das ohne Pivot und ohne Spezialfilter gearbeitet wird sondern mit einem Makro was mir dies möglich macht.
Anbei die Datei mit der Tabelle2 wie sie nach dem Makrolauf dargestellt werden sollte, allerdings ist mir ein Fehler unterlaufen bzw. habe ich etwas vergessen.
Auf der Tabelle2 muss nach jeder Zeile die mit Daten befüllt ist eine Leere Zeile entstehen, d.H.
Zeile mit Daten
Leer
Zeile mit Daten
Leer
Zeile mit Daten
Leer
Zeile mit Daten
Leer
usw.
https://www.herber.de/bbs/user/103824.xlsx
Ich freue mich wirklich über jegliche Reaktion darauf und auf hilfreiche Ideen, sollte noch etwas unklar sein, ich versuche so schnell wie möglich zu reagieren.
Vielen Dank und einen schönen Abend!

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Ohne Duplikate kopieren...
23.02.2016 19:31:19
Michael
Hallo,
Es gibt in vba den Befehl "range.removeduplicates", der ganz ähnlich wie der Spezialfilter wirkt.
Mfg

AW: Ohne Duplikate kopieren...
25.02.2016 12:07:50
Steve
Hallo Marvin,
das Einfachste wäre die Lösung von Michael:
-Tabelle1 komplett nach Tabelle2 kopieren
-Duplikate aussortieren mit der Funktion "RemoveDuplicates"
-Sortieren um entstandene Leerzeilen zu entfernen (unregelmäßig)
-dann Leerzeilen dazwischen fügen nach jedem Datensatz
Sub Kopieren_ohne_Duplikate()
Dim Bereich As Range
Dim i As Long
With Tabelle1
' Kopieren
.Range("A7:J" & .Cells(.Rows.Count, 1).End(xlUp).row).Copy _
Tabelle2.Range("A7")
End With
With Tabelle2
Set Bereich = .Range("A7:J" & .Cells(.Rows.Count, 1).End(xlUp).row)
' Duplikate entfernen
Bereich.RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes
' Sortieren
Bereich.Sort Key1:=.Range("A7"), order1:=xlAscending, Header:=xlYes
' Zeilen einfügen
For i = 1 To .Range("A7:J" & .Cells(.Rows.Count, 1).End(xlUp).row).Rows.Count - 2
Rows(7 + 2 * i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
End With
End Sub
lg Steve

Anzeige
AW: Ohne Duplikate kopieren...
24.02.2016 03:31:59
Piet
Hallo Marvin
anbei ein kleines Makro das diese Aufgabe erfüllt.
Damit meine ich die gewünschte Leerzeile zwischen den Daten.
Sollten es mehr als 500 Daten sein nur die Const Werte aendern s. EndAdr = "A500" & "A8:L500"
Bitte in ein Modulblatt kopieren und laufen lassen. Würde mich freuen wenn es klappt.
mfg Piet
Const EndAdr = "A500" 'End-Adresse
Const ClrTab2 = "A8:L500" 'Lösch Bereich
'mit Leerzeile zwischen Daten
Sub Ohne_Duplikate_kopieren()
Dim Tb1 As Object, i, n, p, z
Set Tb1 = Worksheets("Tabelle1")
Edr = Tb1.Range(EndAdr).End(xlUp).Address
z = 8:  p = 1  '1. Zeile Tabelle 2, Pos.zahl
On Error Resume Next
With Worksheets("Tabelle3")
'alte Tabelle2 löschen
.Range(ClrTab2).ClearContents
For Each i In Tb1.Range("A8", Edr)
If i.Cells(1, 2) = i.Cells(2, 2) And _
i.Cells(1, 3) = i.Cells(2, 3) And _
i.Cells(1, 4) = i.Cells(2, 4) And _
i.Cells(1, 5) = i.Cells(2, 5) And _
i.Cells(1, 6) = i.Cells(2, 6) And _
i.Cells(1, 7) = i.Cells(2, 7) And _
i.Cells(1, 8) = i.Cells(2, 8) And _
i.Cells(1, 9) = i.Cells(2, 9) And _
i.Cells(1, 10) = i.Cells(2, 10) Then
n = n + 1  'gleich=doppelte Werte
Else 'nur ungleiche Werte kopieren
i.Resize(1, 10).Copy
.Cells(z, 1).PasteSpecial xlAll
Application.CutCopyMode = False
.Cells(z, 1) = p:  p = p + 1   'Position
.Cells(z, 12) = n + 1          'doppelte
z = z + 2:  n = 0    'next Zeile Tab-2
End If
Next i
End With
End Sub

Anzeige
AW: Ohne Duplikate kopieren...
24.02.2016 09:43:23
Marvin
Hallo Piet,
vielen Dank für deinen Aufwand und deinen Code,
Erste Frage:
Wohin und an welche Stelle wird dies geschrieben:
Const EndAdr = "A500" 'End-Adresse
Const ClrTab2 = "A8:L500" 'Lösch Bereich
Desweiteren, wenn ich den Code so starte kommt die Meldung:
Fehler beim Kompilieren:
Variable nicht Definiert!
Weist dann auf Sub Ohne_Duplikate_kopieren() (Debug)
und auf
Edr = Tb1.Range(EndAdr).End(xlUp).Address ... Das (EndAdr) in der Klammer.
Beste Grüße und danke für deine Antwort.

AW: nach dem lesen bitte schliessen ...
24.02.2016 22:08:52
Piet
Hallo Marvin
ich nehme an du bist mit VBA noch unerfahren, macht nichts, war mein Fehler.
Const EndAdr = "A500" 'End-Adresse
Const ClrTab2 = "A8:L500" 'Lösch Bereich
Diese Anweisungen Const müssen -über dem Sub Text- stehen, an erster Stelle!
Genau so, wie man es im Text sieht. Const gehört immer bei einem Makro dazu!
Diese Angaben definieren die End-Adresse im Blatt und den Löschbereich.
Ich setze die Adressen gerne in Variable, damit man den Wert aendern kann.
Ich haette es auch so schreiben können: For Each i In Tb1.Range("A8:A500")
Wenn du mehr Zeilen in der Tabelle hast ist es schwer den Text zu tauschen.
So brauchst du bei Bedarf nur den Wert in Const erhöhen: z.B. auf 1000 oder mehr.
Es gibt ja Anfragen wo die Tabelle 500.000 Zeilen hat. Das kann ich ja nicht wissen!
Ich stelle den Thread noch mal offen damit du ihn schneller findest.
Schliesse in bitte nach dem lesen, indem das Haeckchen offen bleibt.
mfg Piet

Anzeige
AW: Ohne Duplikate kopieren...
27.02.2016 11:22:55
Marvin
Hallo zusammen,
wollte nur mitteilen das beide Codes prima funktionierten, musste nur lediglich die ein oder andere Sache ändern und anpassen. Vielen lieben Dank dafür.
Beste Grüße, schönes WE!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige