Excel - doppelte Einträge

[J@ck]

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

[jak]

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:

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

[flinx]

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?

[J@ck]

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!

[flinx]

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

Man kann ja die Zelle komplett löschen.

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

Bitte erklär das genauer.

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

A   B   C
1   2   3 
2   2   3   
3   2   3
3       3
2
4
3
3
2

[J@ck]

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

[flinx]

Ohne Gewähr:

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

[jak]

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>

[J@ck]

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!

[J@ck]

Update:
Es passt! THX²!