erschwert transponieren

Hallo zusammen,
ich habe ein Problem mit der Darstellung einer Exceltabelle die ich in Access weiterverarbeiten möchte. Die Basisdaten werden zur Verfügung gestellt und haben folgende Struktur:
Original
Spalte1 Spalte2 Spalte3 Spalte4 Spalte5 Spalte6 Spalte7 Spalte8 Spalte9 Spalte10
a b c d e f 10% 15% 20% 55%
a b c d g h 20% 17% 33% 30%
a b c d i j 9% 7% 5% 79%
a b c d k l 38% 3% 4% 55%
Beim Transponieren sollen Spalte 1-6 immer kopiert werden und zwar so oft, wie anschließend Werte (in%) folgen. Anschließend sollen die folgenden Werte aus Spalte 7-10 jeweils in eine Zeile kopiert werden.
Ziel
a b c d e f 10%
a b c d e f 15%
a b c d e f 20%
a b c d e f 55%
a b c d g h 20%
a b c d g h 17%
a b c d g h 33%
a b c d g h 30%
a b c d i j 9%
a b c d i j 7%
a b c d i j 5%
a b c d i j 79%
a b c d k l 38%
a b c d k l 3%
a b c d k l 4%
a b c d k l 55%
Das ganze soll automatisch prüfen, wie viele Spalten auf Spalte 6 folgen, da sich die Tabelle erweitern kann.
Ich habe mal nach Werte aus Spalten in Zeilen gesucht, einen Ansatz habe ich mit folgendem Code gefunden, der aber nur sehr rudimentär zu einem Lösunsgansatz führt.

Sub erkunder()
Dim intcol As Integer
Dim lnglastrow As Long
Dim intcounter As Integer
Dim wksOrig As Worksheet
Dim wksCopy As Worksheet
Set wksOrig = Worksheets("Tabelle1")
Set wksCopy = Worksheets("Tabelle2")
Application.ScreenUpdating = False
wksOrig.Activate
intcol = wksOrig.Cells(500, 256).End(xlToLeft).Column
For intcounter = 1 To intcol
lnglastrow = wksCopy.Cells(65536, 1).End(xlUp).Row + 1
wksOrig.Range(Cells(500, intcounter), Cells(833, intcounter)).Copy _
Destination:=wksCopy.Range("A" & lnglastrow)
Next intcounter
Application.ScreenUpdating = False
Set wksCopy = Nothing
Set wksOrig = Nothing
End Sub

Für weitere Ansätze bin ich dankbar!
Viele Grüße
Kai

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Main dim R1 as range dim R2 as range set R1 = Range(cells(1,1), cells(1,6)) lc = cells(1, columns.count).end(xltoleft).column set R2 = Range(cells(1,7), cells(1,lc)) r1.copy sheets(2).cells(1,1).resize(r2.columns.count).pastespecial r2.copy sheets(2).cells(1,7).pastespecial transpose:=true End Sub

Sub Bereich_kopieren() Dim R1 As Range Dim R2 As Range Dim R3 As Range Dim z As Long Dim t As Long Application.ScreenUpdating = False z = Worksheets("Tabelle1").UsedRange.Rows.Count lc = Cells(1, Columns.Count).End(xlToLeft).Column For t = 2 To z Set R1 = Range(Cells(t, 1), Cells(t, 5)) Set R2 = Range(Cells(t, 6), Cells(t, lc)) Set R3 = Range(Cells(1, 6), Cells(1, lc)) R1.Copy Sheets(2).Cells(t * (lc - 5) - (lc - 5), 2).Resize(R2.Columns.Count).PasteSpecial R2.Copy Sheets(2).Cells(t * (lc - 5) - (lc - 5), 7).PasteSpecial Transpose:=True R3.Copy Sheets(2).Cells(t * (lc - 5) - (lc - 5), 1).PasteSpecial Transpose:=True Next t Worksheets("Tabelle5").Rows("2:156").Delete Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread