Schleife zum löschen von Dupletten

Hallöchen,
irgendwie habe ich heute glaube ich einen Knoten im Gehirn. Folgende Problematik: Ich habe in einer Zeile hintereinander in den Zellen Folgendes stehen. Also je Zelle ein Buchstabe (oder auch ein ganzes Wort)
A A B B B B C C D D D D D E E F F F F G G H I I J J J J
rauskommen soll
A B C D E F G H I J
Also nur der jeweils erste Wert soll stehen bleiben und die anderen Zellen sollen gelöscht werden. Nicht aufrücken, einfach nur leer werden. Geht das wirklich nur über 2 verschachtelte Schleifen oder gibt es noch einen eleganteren/kürzeren Trick? Also lasse ich eine Rahmenschleife laufen und wenn Ax=Bx ist, dann läuft die innere Schleife los, so lange bis ein neuer Wert kommt. Aber ist das nicht umständlich?
Wird Zeit das es Feierabend wird ;)
LG,
Tommi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub Ohne_Doppelte() Dim iSpalte_Q As Integer Dim iSpalte_Z As Integer Dim Eingabe As New Collection On Error Resume Next ' das On Error ist wichtig für die Collection !!! For iSpalte_Q = 1 To Cells(1, 256).End(xlToLeft).Column ' ACHTUNG: Collection verlangen Text | ' V Eingabe.Add Item:=Cells(1, iSpalte_Q), Key:=Cells(1, iSpalte_Q).Text If Err = 0 Then iSpalte_Z = iSpalte_Z + 1 Cells(2, iSpalte_Z).Value = Cells(1, iSpalte_Q).Value Else Err.Clear End If Next iSpalte_Q End Sub

Sub a() Dim lngZeile As Long, intErsteSpalte As Integer, intLetzteSpalte As Integer, x As Integer Dim rng As Range lngZeile = 1 intErsteSpalte = 1 intLetzteSpalte = Cells(lngZeile, 256).End(xlToLeft).Column For x = intLetzteSpalte To intErsteSpalte + 1 Step -1 Set rng = Range(Cells(lngZeile, intErsteSpalte), Cells(lngZeile, x - 1)). _ Find(Cells(lngZeile, x).Text, lookat:=xlWhole, LookIn:=xlValues) If Not rng Is Nothing Then Cells(lngZeile, x).ClearContents Next End Sub

Hallo Thomas,
wenn es so sein soll, wie du es dargestellt hast unter "rauskommen soll", dann für beliebig viel Zeilen ab Zeile 1
'
' nun erfolgt der Übertrag (aus eimem temporären Array) in die gleiche Zeile
'


Public Sub Ohne_Doppelte_I()
Dim lZeile      As Long           ' der For/Next Schleifen-Index der Zeilen
Dim iSpalte     As Integer        ' der For/Next Schleifen-Index der abzusuchenden Spalten
Dim Eingabe     As New Collection ' die Collection - die Sammlung ohne dopplete
Dim aAusgabe()  As Variant        ' der Array zur Aufnahme der Daten ohne doppelte
Dim iIndex      As Integer        ' der Index zum Array
Application.ScreenUpdating = False ' den Bildschirm-Update unterbinden
On Error Resume Next ' das On Error ist wichtig für die Collection !!!
For lZeile = 1 To Cells(Rows.Count, 1).End(xlUp).Row     ' ab Zeile 1 bis zur letzten  _
belegten
Set Eingabe = Nothing                                 ' die Collection löschen
Erase aAusgabe                                        ' den Array löschen
iIndex = 0                                            ' den Index zurücksetzen
For iSpalte = 1 To Cells(lZeile, 256).End(xlToLeft).Column ' die Spalten abarbeiten
Eingabe.Add Item:=Cells(lZeile, iSpalte), Key:=Cells(lZeile, iSpalte).Text
If Err = 0 Then                                    ' gab es einen doppelten Eintrag ?
iIndex = iIndex + 1                             ' den Index hochrechnen
ReDim Preserve aAusgabe(iIndex)                 ' den Array redimensionieren
aAusgabe(iIndex) = Cells(lZeile, iSpalte).Value ' den Wert EINMAL in den Array
Else                                              ' sonst
Err.Clear                                       ' den Fehler (weil dopplet) löschen
End If
Next iSpalte                                          ' die nächste Spalte
'       nun wird die auf doppelte untersuchte Zeile gelöscht und der Array übertragen
Range(Cells(lZeile, 1), Cells(lZeile, Cells(lZeile, 256).End(xlToLeft).Column)). _
ClearContents
For iIndex = 1 To UBound(aAusgabe)
Cells(lZeile, iIndex).Value = aAusgabe(iIndex)     ' die Spalten aus dem Array füllen
Next iIndex
Next lZeile                                              ' die nächste Zeile holen
Application.ScreenUpdating = True  ' den Bildschirm-Update wieder zulassen
End Sub

Gruß Peter

Beliebteste Forumthreads (12 Monate)

Schleife zum löschen von Dupletten

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread