WCM Forum - Excel - doppelte Einträge

WCM Forum (http://www.wcm.at/forum/index.php)

- Programmierung (http://www.wcm.at/forum/forumdisplay.php?f=17)

- - Excel - doppelte Einträge (http://www.wcm.at/forum/showthread.php?t=131795)

Excel - doppelte Einträge

Frage: Gibt es eine Möglichkeit (ganz doll wär ein Makro) dass mir alle Einträge in Spalte A durchsucht und diejenigen löscht die NICHT DOPPELT oder MEHRFACH vorhanden sind. Muss also die Einzelgänger löschen.
Was ich beim googeln gefunden habe macht es genau umgekehrt :-(

Und könnte man dies noch soweit erweitern dass er mir noch zusammenzählt wieviele Einträge (bei doppelt "2", bei drei Einträgen "3" usw) anzeigt?

Thx4Help!

Lg
Jack

Meine Idee:
Die ganze Tabelle drei mal durchlaufen, beim ersten mal zählen und in eine Spalte schreiben, beim zweiten Mal die einfachen löschen und beim dritten mal das ganze "zusammenkopieren" damit keine Leerzeilen sind.

Ist die Reihenfolge irgendwie wichtig, oder kann man vor der Ausführung die Spalte A sortieren? Würde einiges vereinfachen...

Han das nicht ausprobiert:

Code:

Private Function findDublicate(row As Integer, targetCol As Integer, in_table As String) As Integer

'Prueft ob ein Eintrag bereits existiert

Dim i As Integer, a, b As String

a = Worksheets(in_table).Cells(row, 1).Value

i = 1

findDublicate = -1

Do

 b = Worksheets(in_table).Cells(i, 1).Value

  If (a = b) Then

  findDublicate = i

  Exit Do

  End If

 i = i + 1

Loop While (i < row)

End Function

Private Sub increase(inTable As String, row As Integer, col As Integer)

 With (Worksheets(inTable).Cells(row, col))

  If (Value <> "") Then Value = Value + 1

  Else: Value = 1

  End If

 End With

End Sub

Private Sub Count(targetCol As Integer)

Dim row, currentRow  As Integer

Dim tempCell

currentRow = 0

Do

 currentRow = currentRow + 1

 tempCell = Worksheets("Tabelle1").Cells(currentRow, 1)

 row = findDublicate(currentRow, targetCol, "Tabelle1")

 If (row <> -1) Then Call increase("Tabelle1", currentRow, targetCol)

 End If

Loop While (tempCell.Value <> "")

End Sub

Private Sub Delete(targetCol As Integer)

'Delete löscht nur die Spalten die einzeln sind, sortiert aber keine Doppelten Einträge aus.

'Wenn du das willst musst du statt

'if ...Value = 1) if ((c.Value = 1) Or (c.Value=""))

'schreiben.

Dim i As Integer

i = 0

Do

 i = i + 1

 If (Worksheets("Tabelle1").Cells(i, targetCol).Value = 1) Then

  Worksheets("Tabelle1").Cells(i, 1).Value = ""

  'Wenn du noch weitere Zellen löschen willst kannst du das hier dazuschreiben:

  'Worksheets("Tabelle1").Cells(i, 2).Value = ""

  'Worksheets("Tabelle1").Cells(i, 3).Value = ""

 End If

Loop While (Worksheets("Tabelle1").Cells(i, 1).Value <> "")

End Sub

Private Sub copy()

'Not implemented

End Sub



Sub main()

Dim targerCol As Integer

'targetCol ist die Spalte, in die die "Zählung" geschrieben wird

targetCol = 2

Call Count(targetCol)

Call Delete(targetCol)

copy

End Sub

Jak

Willst die Mehrfachvorkommen reduzieren auf einmal und die Anzahl (daneben? ) hinschreiben oder sollen sie erhalten bleiben?
Abbruchbedingung für eine Spalte ist ein leeres Feld?

Also ich würd mich freuen wenn die Daten erhalten bleiben, sprich in einer eigenen Spalte geschrieben werden.
Und Leerzeilen sollte es keine geben (bei den Rohdaten). Jedoch beim Löschen der Einzelnen, entstehen da welche?

Ist dumm gefragt und ich hab keine Ahnung von Makroprogrammierung (naja, klitzekleines bisschen), die Daten zum Testen befinden sich in der Firma.

Aber in erster Linie ein BIG THX für die Hilfe!

Zitat:

Jedoch beim Löschen der Einzelnen, entstehen da welche?

Man kann ja die Zelle komplett löschen.

Zitat:

Also ich würd mich freuen wenn die Daten erhalten bleiben, sprich in einer eigenen Spalte geschrieben werden.

:confused: Bitte erklär das genauer.

Vielleicht so (A bleibt erhalten, Einfachnennungen nicht berücksichtigt)?

Code:

Hab ich mich wohl verschrieben:

In Spalte A sind die Rohdaten, in Spalte 2 wärs toll wenn nur die rauskommen die mehrfach vorhanden sind und in Spalte 3 idealerweise eine Summierung (wie oft sind diese Daten vorhanden) um auf den ersten Blick zu sehen wer öfter angezeigt wird.
Könnte man mit Strafstatistik vergleichen: Jede Person hat ne Nummer, wer mehrmals "registriert" bzw. eingetragen wurde, wird sichtbarer, am sichtbarsten wird wer recht oft eingetragen wurde.
Dabei handelt es sich um Datensätze so um die 45.000 Zeilen in 18 Blättern.

Es ist eine vereinfachte Darstellung, geht jedenfalls nicht um Straftäter. Eher im medizinischen Bereich aber das tut eben nix zur Sache :rolleyes:

Ohne Gewähr:

Code:

Sub multiple()

 ActiveSheet.Columns("A:A").Select

 Selection.Copy

 ActiveSheet.Range("B1").Select

 ActiveSheet.Paste

 

 i = 2

 h = 2

 

Application.ScreenUpdating = False

While (ActiveSheet.Cells(i, 2).Value <> "")

   Count = 1

   j = i + 1

   While (ActiveSheet.Cells(j, 2).Value <> "")

      If ActiveSheet.Cells(i, 2).Value = ActiveSheet.Cells(j, 2).Value Then

        Count = Count + 1

        ActiveSheet.Cells(j, 2).Delete Shift:=xlUp

      Else

        j = j + 1

      End If     

   Wend

   If Count > 1 Then

       ActiveSheet.Cells(h, 3).Value = Count

       h = h + 1

       i = i + 1

   Else

   ActiveSheet.Cells(i, 2).Delete Shift:=xlUp

   End If

Wend

Application.ScreenUpdating = True

End Sub

S.a. Attachment

hab' dich wohl falsch verstanden.
Der Code soltle das gewünschte erledigen:

'Prueft ob ein Eintrag bereits existiert
Private Function findDublicate(row As Long, col As Long, in_table As String) As Long
Dim i As Integer, a, b As String
a = Worksheets(in_table).Cells(row, col).Value
i = 1
findDublicate = -1
Do
b = Worksheets(in_table).Cells(i, col).Value
If (a = b) Then
findDublicate = i
Exit Do
End If
i = i + 1
Loop While (i < row)
End Function

Private Function find(whatText As String, whatCol As Long, fromWB As String) As Long
Dim row As Integer, a As String
row = 0
Do
row = row + 1
a = Worksheets(fromWB).Cells(row, whatCol).Value
If (a = whatText) Then Exit Do
Loop While a <> ""
find = row
End Function

'erhoeht die Zahl
Private Sub increase(inTable As String, srcRow As Long, tCol As Long)
Dim temp
Dim tRow As Long
Dim srcText As String
srcText = Worksheets(inTable).Cells(srcRow, 1).Value
tRow = find(srcText, tCol, "Tabelle1")
'kopiert beim 1.Mal den Text aus Spalte A
If (Worksheets(inTable).Cells(tRow, tCol).Value = "") Then Worksheets(inTable).Cells(tRow, tCol).Value = Worksheets(inTable).Cells(srcRow, tCol - 1).Value
tCol = tCol + 1
'Wenn in der Zählspalte schon was steht wird die Zahl erhöht
If Worksheets(inTable).Cells(tRow, tCol).Value <> "" Then Worksheets(inTable).Cells(tRow, tCol).Value = Worksheets(inTable).Cells(tRow, tCol).Value + 1
'Sonst auf 2 gesetzt
If Worksheets(inTable).Cells(tRow, tCol).Value = "" Then Worksheets(inTable).Cells(tRow, tCol).Value = 2
End Sub

Sub main()
Dim row, currentRow, targerCol, targetRow As Long
'targetCol ist die Spalte, in die die "Zählung" geschrieben wird (A=1, B=2, C=3,...)
targetCol = 2
currentRow = 1
targetRow = 1
row = 0
Do
currentRow = currentRow + 1
row = findDublicate((currentRow), 1, "Tabelle1")
If (row <> -1) Then
Call increase("Tabelle1", (row), (targetCol))
End If
Loop While (Worksheets("Tabelle1").Cells(currentRow, 1).Value <> "")
End Sub

Hab's aber nicht ausprobiert, versuch es halt an einer Kopie der Daten...

Es wird angenommen, daß die Tabelle aus ist, wenn eine Zelle der Spalte A leer ist.

Du sagst etwas von 18000 Zeilen, das könnte mit dem Code seeehr lange dauern, er ist ziemlich ineffizent.

Siehe test.zip

Jak

<edit>war zu langsam, versuch mal den Code von Flinx, ist vermutlich besser...</edit>

Thx an euch beiden für die Files!

Jak: Leider meldet deine Mappe nach einigen Sekunden einen Indexfehler. Keine Ahnung was genau das heißt, er will immer debuggen.

Flinx: Scheint zu funken, jedoch zählt er nicht richtig zusammen, ist immer um 1 zu wenig. Aber sonst siehts gut aus!
THX!

Update:
Es passt! THX²!

Zitat:

Update:Es passt! THX²!

Fein.
Wennst nur die einfachen eliminiert haben willst und die doppelten erhalten:

Code:

Sub multiple2()

 'Create Temp

 ActiveSheet.Columns("A:A").Select

 Selection.Copy

 ActiveSheet.Range("E1").Select

 ActiveSheet.Paste

 

 i = 2

 h = 2

 

Application.ScreenUpdating = False

While (ActiveSheet.Cells(i, 5).Value <> "")

   Count = 1

   j = i + 1

   While (ActiveSheet.Cells(j, 5).Value <> "")

      If ActiveSheet.Cells(i, 5).Value = ActiveSheet.Cells(j, 5).Value Then

        If Count = 1 Then ActiveSheet.Cells(h, 6).Value = ActiveSheet.Cells(i, 5).Value

        Count = Count + 1

        h = h + 1

        ActiveSheet.Cells(h, 6).Value = ActiveSheet.Cells(j, 5).Value

        ActiveSheet.Cells(j, 5).Delete Shift:=xlUp

      Else

        j = j + 1

      End If

     

   Wend

   If Count > 1 Then

       ActiveSheet.Cells(h, 7).Value = Count

       i = i + 1

       h = h + 1

   Else

   ActiveSheet.Cells(i, 5).Delete Shift:=xlUp

   End If

Wend

Application.ScreenUpdating = True

End Sub

Hallo Jack.Ripper,
hier zwei Tipps aus meiner Excel-Sammlung.

Doppelte Datensaetze finden

Bei Datenbank-Anwendungen, beispielsweise einer umfangreichen Adressdatei, taucht haeufig folgendes Problem auf: Datensaetze werden doppelt eingegeben. Um den Wust solcher "Fehleingaben" einzuschraenken, sollten Sie sich einmal monatlich etwas Zeit nehmen, um die Duplikate zu entfernen. Doch keine Angst: Dazu benoetigen Sie nicht Stunden; das ist mit einigen
wenigen Mausklicks zu realisieren, wenn Sie dabei wie folgt vorgehen:
1. Oeffnen Sie ueber das Menue "Datei/Oeffnen" die zu ueberpruefende Datei.
2. Markieren Sie nun eine beliebige Zelle in der Datenbank. Waehlen Sie im Menue "Daten" den Menuepunkt "Filter" und den Unterpunkt "Spezialfilter" an. So koennen Sie die Datensaetze besser ueberblicken.
3. Die Vorgabe im Feld "Kriterienbereich" loeschen Sie und aktivieren anschliessend das Kontrollkaestchen "Keine Duplikate".
4. Bestaetigen Sie das Dialogfeld mit einem Klick auf "OK". Direkt im Anschluss an Ihre Bestaetigung wird die komplette Datenbank ausgewertet und auf doppelte Datensaetze hin ueberprueft. Je nach Groesse der Datenbank kann das einige Zeit in Anspruch nehmen.
Wenn der Suchvorgang beendet ist, taucht in der Statuszeile folgende Meldung auf: "x Datensaetze von y gefunden" Die Anzahl der doppelten Datensaetze wird dabei als Differenz zwischen den Werten x und y angezeigt. Stimmen beide Werte ueberein, sind auch keine Duplikate vorhanden.

Doppelte Listeneintraege loeschen

Raeumen Sie Ihre Listen auf, und lassen Sie Excel alle Duplikate entfernen. Doppelte Eintraege blaehen Adresslisten oder andere Daten auf. Um Ihre Listen zu bereinigen, entfernen Sie alle
Duplikate automatisch mit der Filterfunktion von Excel. Benutzen Sie dazu den Befehl Daten/
Filter/Spezialfilter. Im Dialog schalten Sie im Bereich Aktion die Option Liste an gleicher Stelle
filtern ein. Definieren Sie den Listenbereich: Markieren Sie im Tabellendokument die gesamte Liste mit gedrueckter linker Maustaste. Die entsprechenden Koordinaten erscheinen im Feld Listenbereich des Dialogs. Markieren Sie die Koordinatenangabe, und kopieren Sie diese mit [Strg-C] in den Arbeitsspeicher. Druecken Sie die [Tab]-Taste, und fuegen Sie die Bereichsangabe mit [Strg-V] in das Feld Kriteri-enbereich ein. Zum Abschluss schalten Sie die
Option Keine Duplikate ein. Den Filterlauf starten Sie mit dem Klick auf den OK-Button. Excel entfernt nun automatisch alle doppelten Datensaetze im festgelegten Listenbereich.

Hallo Christoph!

Danke für dein ausführliches Posting, aber meine Problemstellung war genau umgekehrt. Hat sich übrigens erledigt :)