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²!