Bereinigung Liste

Forumthread: Bereinigung Liste

Bereinigung Liste

Bernd

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

So, so! Gr.Erwartung u.viel Arbeit b.d.Hitze! orT

02.07.2010 08:28:45

Luc:-?

Morn! Luc :-?

Verdichtung

02.07.2010 11:02:27

Erich

Hi Bernd,
probier mal diesen "Verdichter". Die Ausgabe erfolgt auf einem neuen Blatt:


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

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Danke/ beide Lösungen funktionieren wie gewünscht!

05.07.2010 15:08:43

Bernd

Daten Normalisieren

02.07.2010 11:09:53

NoNet

Hallo Bernd,
hier mein Lösungsvorschlag per VBA :

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

Gruß, NoNet

gegen 2:1

Beliebteste Forumthreads (12 Monate)

Forumthread: Bereinigung Liste

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

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread