Zellen aus mehreren Spalten sortieren

Katrin · 2021-01-26T14:19:23+00:00

Hallo, ich habe eine Tabelle vorliegen, in der jeweils eine Person pro Zeile aufgelistete ist und diese Person jeweils mit verschiedenen Merkmalen beschrieben ist. Die Merkmale verteilen sich auf die Spalten hinter dem Namen. Die Merkmale sind leider nicht sortiert, d.h. ich finde das Alter einer Person mal in Spalte B, das der nächsten Person in Spalte D und das der dritten Person in Spalte C. Ich möchte aber, dass das Alter immer in Spalte B zu finden ist. Ich habe mal eine Beispieldatei (mit weniger Personen und Merkmalen) angehängt. Tabelle 1 zeigt, wie die Daten im Original vorliegen, Tabelle 2 zeigt wie ich sie gerne vorliegen hätte. Da die die Tabelle ziemlich groß ist, brauche ich eine automatische Lösung via VBA. Ich hab schon gesucht und gesucht, bin aber nicht mal annähernd in die Richtung einer Lösung gekommen. Hat jemand eine Idee? https://www.herber.de/bbs/user/143327.xlsx

Hallo Katrin,
... mit je einer Definitionsliste der "Farben"

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D	E	F	G	H
1	Jana	28 Jahre	Braun	165 cm	abenteuerlustig			Farbe
2	Maria	Blond	36 Jahre	chaotisch	195 cm			Rot
3	Kevin	ehrgeizig	168 cm	Rot	70 Jahre			Blond
4	Nikolas	177 cm	familiär	60 Jahre	Braun			Braun
5	Diana	180 cm	kreativ	Blond	48 Jahre
6

Verwendete Systemkomponenten: [Windows (32-bit) NT 6.02] MS Excel 2010

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

und anaolog der "Eigenschaften", könnte z.B. so aussehen:

Arbeitsblatt mit dem Namen 'Tabelle2'
	A	B	C	D
1	Jana	28 Jahre	165 cm	Braun
2	Maria	36 Jahre	195 cm	Blond
3	Kevin	70 Jahre	168 cm	Rot
4	Nikolas	60 Jahre	177 cm	Braun
5	Diana	48 Jahre	180 cm	Blond
6

Zelle	Format	Wert
B1	0 "Jahre"	28
C1	0 "cm"	165

Zelle	Formel
B1	=WENNFEHLER(AGGREGAT(15;6;WECHSELN(Tabelle1!$B1:$E1;"Jahre";"")/SUCHEN("Jahr";Tabelle1!$B1:$E1)^0;1);"")
C1	=WENNFEHLER(AGGREGAT(15;6;WECHSELN(Tabelle1!$B1:$E1;"cm";"")/SUCHEN("cm";Tabelle1!$B1:$E1)^0;1);"")

Verwendete Systemkomponenten: [Windows (32-bit) NT 6.02] MS Excel 2010

Die Formel für E1 natürlich analog zu D1.
Alternativ wäre auch eine PowerQuery-Lösung möglich. Aber auch die erfordert die zusätzlichen Defintionslisten.
Gruß Werner
.. , - ...

Hallo Katrin,
teste mal:

Option Explicit

Public Sub AdjustData()

    Dim objCell As Range
    Dim strFirstAddress As String
    Dim vntItem As Variant, avntValues() As Variant
    Dim lngRow As Long
    Dim objDictionary As Object

    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")

    With Worksheets("Tabelle1")

        Redim avntValues(1 To .Cells(.Rows.Count, 1).End(xlUp).Row, 1 To 5)

        For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row

            avntValues(lngRow, 1) = .Cells(lngRow, 1).Value

            objDictionary.Item(Key:=.Cells(lngRow, 1).Address) = vbNullString

        Next

        Set objCell = .Cells.Find(What:="Jahre", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

        If Not objCell Is Nothing Then

            strFirstAddress = objCell.Address

            Do

                If objCell.Column > 1 Then

                    avntValues(objCell.Row, 2) = objCell.Value

                    objDictionary.Item(Key:=objCell.Address) = vbNullString

                End If

                Set objCell = .Cells.FindNext(After:=objCell)

            Loop Until objCell.Address = strFirstAddress
        Else
            Call MsgBox("Suchbegriff ''Jahre'' nicht gefunden.", vbCritical, "Programmabbruch")
            Exit Sub
        End If

        Set objCell = .Cells.Find(What:="cm", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

        If Not objCell Is Nothing Then

            strFirstAddress = objCell.Address

            Do

                If objCell.Column > 1 Then

                    avntValues(objCell.Row, 3) = objCell.Value

                    objDictionary.Item(Key:=objCell.Address) = vbNullString

                End If

                Set objCell = .Cells.FindNext(After:=objCell)

            Loop Until objCell.Address = strFirstAddress
        Else
            Call MsgBox("Suchbegriff ''cm'' nicht gefunden.", vbCritical, "Programmabbruch")
            Exit Sub
        End If

        For Each vntItem In Array("Blond", "Rot", "Braun", "Grau")

            Set objCell = .Cells.Find(What:=vntItem, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

            If Not objCell Is Nothing Then

                strFirstAddress = objCell.Address

                Do

                    If objCell.Column > 1 Then

                        avntValues(objCell.Row, 4) = objCell.Value

                        objDictionary.Item(Key:=objCell.Address) = vbNullString

                    End If

                    Set objCell = .Cells.FindNext(After:=objCell)

                Loop Until objCell.Address = strFirstAddress
            End If
        Next

        For Each objCell In .Range(.Cells(1, 2), .Cells(.Rows.Count, 5).End(xlUp))

            If Not objDictionary.Exists(Key:=objCell.Address) Then _
                avntValues(objCell.Row, 5) = objCell.Value

        Next

        .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 5).Value = avntValues

    End With

    Set objDictionary = Nothing

End Sub

Gruß
Nepumuk

Zellen aus mehreren Spalten sortieren

Forumthread: Zellen aus mehreren Spalten sortieren

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Zellen aus mehreren Spalten sortieren

Forumthread: Zellen aus mehreren Spalten sortieren

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread