Zellen aus mehreren Spalten sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

Zellen aus mehreren Spalten sortieren

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen aus mehreren Spalten sortieren

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

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread