Transponieren und Über tragen per Makro

Hallo zusammen,
ich habe folgendes Problem: Ich habe in einem Tabellen Blatt mehrere Spalten mit einer Kategorie und verschiedenen Ausprägungen. Diese soll in ein anderes Blatt "transponiert" werden.
Beispiel:
in A1 steht "Obst", von A2 bis A5 steht dann beispielsweise " Orange", "Kirsche" und "Birne"etc.
in B1 steht "Gemüse", von A2 bis A8 steht dann beispielsweise " Gurke", "Tomate" etc.
Im neuen Tabellenblatt soll dann in A1 stehen "Orange" und in A2 "Obst", in B1 entsprechend " Kirsche " und in B2 "Obst" usw. Dies soll für alle Kategorien und Ausprägungen fortgeführt werden, also weiter soll beispielsweise in C1 " Gurke" und in C2 dann Gemüse stehen und so fort.
Die Anzahl an Kategorien und Ausprägungen ist immer variabel.
Lässt sich dies irgendwie per Makro lösen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
so?

Tabelle1

	A	B	C
1	Obst	Gemüse	Fleisch
2	Orange	Gurke	Rind
3	Kirsche	Tomate	Kalb
4	Birne		Schwein
5			Huhn
6			Lamm

Tabelle2

	A	B	C	D	E	F	G	H	I	J
1	Orange	Kirsche	Birne	Gurke	Tomate	Rind	Kalb	Schwein	Huhn	Lamm
2	Obst	Obst	Obst	Gemüse	Gemüse	Fleisch	Fleisch	Fleisch	Fleisch	Fleisch

http://excel-inn.de/dateien/vba_beispiele/tabellenanzeige_in_html_addin.zip

http://Hajo-Excel.de/tools.htm

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.10 einschl. 64 Bit

in ein Modul

Sub Obstladen()

    Dim LR As Double, LC1 As Integer, LC2 As Integer
    Dim TB1, TB2, SP As Integer
    
    Set TB1 = Sheets("Tabelle1")
    Set TB2 = Sheets("Tabelle2")
    
    LC1 = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile 
    
    With TB1
        For SP = 1 To LC1
            LC2 = TB2.Cells(1, TB2.Columns.Count).End(xlToLeft).Column + 1
            LC2 = IIf(TB2.Cells(1, 1) = "", 1, LC2) ' zu Beginn=1 
            
            LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte 
            
            TB2.Range(TB2.Cells(1, LC2), TB2.Cells(1, LC2 + LR - 2)) = _
                Application.Transpose(.Range(.Cells(2, SP), .Cells(LR, SP)))
            TB2.Range(TB2.Cells(2, LC2), TB2.Cells(2, LC2 + LR - 2)) = .Cells(1, SP)
        Next
    End With
End Sub

LG UweD

Sub Obstladen() Dim StZ As Integer, StS As Integer Dim ZiZ As Integer, ZiS As Integer Dim LR As Double, LC1 As Integer, LC2 As Integer Dim TB1, TB2, SP As Integer StZ = 3 'Startzeile 3 StS = 2 'Startspalte B ZiZ = 1 'Zielzeile 1 ZiS = 1 'Zielspalte A Set TB1 = Sheets("Tabelle1") Set TB2 = Sheets("Tabelle2") With TB1 LC1 = .Cells(StZ, .Columns.Count).End(xlToLeft).Column For SP = StS To LC1 LC2 = Application.Max(TB2.Cells(ZiZ, TB2.Columns.Count).End(xlToLeft).Column + 1, ZiS) 'Wenn Spalte 1 leer ist, darf keine 1 addiert werden If ZiS = 1 And TB2.Cells(ZiZ, ZiS) = "" Then LC2 = 1 LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte TB2.Range(TB2.Cells(ZiZ, LC2), TB2.Cells(ZiZ, LC2 + LR - StZ - 1)) = _ Application.Transpose(.Range(.Cells(StZ + 1, SP), .Cells(LR, SP))) TB2.Range(TB2.Cells(ZiZ + 1, LC2), TB2.Cells(ZiZ + 1, LC2 + LR - StZ - 1)) = _ .Cells(StZ, SP) Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Transponieren und Über tragen per Makro

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread