Kniffelaufgabe: Tabelle neu strukturieren

[Markus L]

Hallo Liebe Leute,
Um das Problem was ich habe zu vereinfachen, hab ich mir mal ein Beispiel ausgedacht:
Ausgangssituation:
Arbeitsblatt 1.:
A B C D E F G H I usw.
1 Hund Katze Maus Affe Maus Hund Adler Gorilla Fuchs
2 Maus Affe Hund Adler Gorilla Fuchs
3 Katze Adler Maus Hund Katze Gorilla Affe Maus Adler

Ziel: Im neuen Arbeitsblatt soll der Inhalt der Tabelle neu strukturiert werden, so dass die Reihenfolge von A1 bis I3 in drei Spalten von A-C aufgelistet wird und so dass die leeren Zellen weg fallen.
Arbeitsblatt 2.:
A B C
1 Hund Katze Maus
2 Affe Maus Hund
3 Adler Gorilla Fuchs
4 Maus Affe Hund
5 Adler Gorilla Fuchs
6 Katze Adler Maus
7 Hund Katze Gorilla
8 Affe Maus Adler

Ich hoffe Ihr versteht was ich möchte.
Das ist nur eine vereinfachte Darstellung, in Wirklichkeit sind über 20.000 Zellen
Was muss ich eingeben um das zu erreichen.
Für Antworten wäre ich sehr dankbar.
Mit freundlichen Grüßen,
Markus

 

[Thomas Ramel]

Grüezi Markus

Hmmm, da hört sich eigentlich nach 'Transponieren' an, wobei allerdings die Anzahl der Spalten ein Problem sein könnte.

- Markiere und kopiere deine Daten
- Klicke dann A1 im neuen Tabellenblatt mit der rechten Maustaste an
- Wähle 'Inhalte einfügen'
- [x] Transponieren
- [OK]

Wenn Du allerdings mehr Zeilen hast wie im zweiten Tabellenblatt Spalten zur Verfügung stehen, dann ist das Ganze so nicht möglich.

 

[Markus L]

Danke für die Antwort, aber wie Du schon sagts läßt sich mit dem Befehl Mtrans nur die Tabelle um 90° Drehen.

Aber in einem anderen Forum hat man mir gut geholfen. Die Lösung ist folgender Makro:

Option Explicit

Sub dreier()
'Deklarationen
Dim arrAll As Object
Dim Bereich As Range, Feld As Range
Dim x As Variant, y()
Dim strPart As String
Dim d As Long, i As Long, j As Long, k As Integer

'Parameter
Set Bereich = Sheets("Tabelle1").Range("A1").CurrentRegion
Set arrAll = CreateObject("System.Collections.ArrayList")

'Einzelbegriffe in Array einlesen
For Each Feld In Bereich
x = Split(Feld, Space(1))
For i = 0 To UBound(x)
strPart = x(i)
arrAll.Add strPart
Next
Next

'Zeilen in Tabelle 2 ermitteln
d = IIf(arrAll.Count Mod 3 > 0, Int(arrAll.Count / 3) + 1, arrAll.Count / 3)
ReDim y(1 To d, 1 To 3)

'Ein- in zweidimensionales Array umformen
i = -1
For j = 1 To d
For k = 1 To 3
i = i + 1
If i < arrAll.Count Then
y(j, k) = arrAll(i)
Else
Exit For
End If
Next k
Next j

'Ausgabe in Tabelle 2
Sheets("Tabelle2").Range("A1:C" & d) = y
End Sub


Schönen Tag noch,

MFG Markus