Bereinigung Liste

Hallo zusammen,
ich habe eine Liste die aus vier Spalten und ca. 6000 Datensätzen besteht. Spalte A enthält Namen, Spalten B-D jeweils alphanumerische Zeichen.
Nun würde ich die Liste gerne "auf Knopfdruck" folgendermaßen bereinigen:
Es gibt mehrfach den selben Namen aus Spalte A, aber mit unterschiedlichen Werten in Spalte B-D. Das Ziel sollte eine Liste sein, bei der jeder Name aus Spalte A nur einmal vorkommt und in den Spalten B-D werden dann die alphanumerischen Werte aufgelistet aus der ursprünglichen Liste (also gerade auch von denen, die zuvor gelöscht wurden). Beispiel: Name wäre z. B. Berlin. Dieser Name ist z. B. in der Liste 3 x vorhanden, jeweils mit unterschiedlichen Werten in dern Spalten B-D. Nach Bereinigung sollte dann nur 1x Berlin vorhanden sein und in den Spalten B- .... die Werte des übriggebliebenen Datensatzes zuzüglich der gelöschten Werte aufgelistet werden. Dabei sollen die entsprechenden Werte einfach in die Spalten B- J (hoffentlich habe ich mich nicht verzählt) nacheinander reingeschrieben werden. Bei mehr als 3 identischen Namen verlängert sich natürlich die Spaltenanzahl.
Da die Liste ca. 6000 Zeilen hat, sollte die Lösung auch einigermaßen "schnell" funktionieren, damit der Rechner nicht auf bestimmte Zeit "blockiert" ist.
Viele Grüße
Bernd
Ist hoffe, ich konnte es einigermaßen verständlich ausdrücken.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub Verdicht() Dim lngQ As Long, arrQ, zz As Long, ii As Long Dim oDic As Object, lngM As Long, arrA, arrN, arrE ' Quelldaten einlesen lngQ = Cells(Rows.Count, 1).End(xlUp).Row arrQ = Cells(1, 1).Resize(lngQ, 4) ' Dictionary aufbauen Set oDic = CreateObject("Scripting.Dictionary") For zz = 1 To lngQ If oDic.Exists(arrQ(zz, 1)) Then arrA = oDic(arrQ(zz, 1)) ReDim arrN(0 To UBound(arrA) + 3) If lngM

Sub DatenNormalisierung() Dim lngS As Long, lngZ1 As Long, lngZ2 As Long For lngZ1 = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Not IsEmpty(Cells(lngZ1, 1)) And _ Application.CountIf(Range("A1:A" & lngZ1 - 1), Cells(lngZ1, 1)) > 0 Then lngZ2 = Range("A1:A" & lngZ1 - 1).Find(Cells(lngZ1, 1), lookat:=xlWhole).Row For lngS = 2 To Cells(lngZ1, Columns.Count).End(xlToLeft).Column If Application.CountIf( _ Range(Cells(lngZ2, 2), Cells(lngZ2, Columns.Count)), _ Cells(lngZ1, lngS)) = 0 Then Cells(lngZ2, Columns.Count).End(xlToLeft).Offset(, 1) = _ Cells(lngZ1, lngS) End If Next Rows(lngZ1).EntireRow.Delete shift:=xlUp lngZ1 = lngZ1 - 1 End If Next End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread