transponieren, löschen per vba

[Dude85]

Hallo zusammen

Ich würde es schätzen, wenn ihr mir erneut helfen könntet!
Meine Tabelle muss wie folgt transponiert werden:

Die Werte aus der Spalte Q (Bereich Q3:Q10) transponieren nach R2:Y2.
Danach Zeilen 3:10 löschen.

Danach eine Schlaufe bis zum letzten Eintrag (unterschiedlich viele Zeilen, nicht fix). Das heisst...
Q4:Q11 nach R3:Y3 transponieren
Zeilen 4:11 löschen

Q5:Q12 nach R4:Y4 transponieren
Zeilen 5:12 löschen

Der zu transponierende Block umfasst immer 8 Werte/Zeilen.
usw.

Vorher

Tabelle1

	Q	R	S	T	U	V	W	X	Y
1	Eintrag	Meta1	Meta1_Ref	Meta2	Meta2_Ref	Meta3	Meta3_Ref	Bem	Label
2	1
3	Meta1
4	Meta1_Ref
5	Meta2
6	Meta2_Ref
7	Meta3
8	Meta3_Ref
9	Bem
10	Label
11	2
12	Meta1
13	Meta1_Ref
14	Meta2
15	Meta2_Ref
16	Meta3
17	Meta3_Ref
18	Bem
19	Label
20	3
21	Meta1
22	Meta1_Ref
23	Meta2
24	Meta2_Ref
25	Meta3
26	Meta3_Ref
27	Bem
28	Label

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8


Nachher


Tabelle1

	Q	R	S	T	U	V	W	X	Y
1	Eintrag	Meta1	Meta1_Ref	Meta2	Meta2_Ref	Meta3	Meta3_Ref	Bem	Label
2	1	Meta1	Meta1_Ref	Meta2	Meta2_Ref	Meta3	Meta3_Ref	Bem	Label
3	2	Meta1	Meta1_Ref	Meta2	Meta2_Ref	Meta3	Meta3_Ref	Bem	Label
4	3	Meta1	Meta1_Ref	Meta2	Meta2_Ref	Meta3	Meta3_Ref	Bem	Label

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8


Wie geht das mit vba?
Die Transponierung von unten nach oben durchlaufen lassen?

Danke für die tolle Hilfe!

Liebe Grüsse
Urs - Office 2010

[Crazy Tom]

Hi

so habe ich es getestet

Code:

Sub test()
   Dim lngZiel As Long
   Do
       lngZiel = Cells(Rows.Count, 18).End(xlUp).Row + 1
       Cells(lngZiel + 1, 17).Resize(8, 1).Copy
       Cells(lngZiel, 18).PasteSpecial Paste:=xlPasteAll, Transpose:=True
       Cells(lngZiel + 1, 1).Resize(8, 1).EntireRow.Delete
   Loop While Cells(lngZiel + 1, 17) <> ""
End Sub

MfG Tom

[Dude85]

Lieber Tom

Das ist suuuper
Merci für den Code!

Wünsche dir und allen ein sonniges Weekende.

Mfg - Urs

[RPP63]

Moin!
Sowas ist auch problemlos mit einfachen Formeln lösbar.
Erst gestern habe ich für ein ähnliches Problem eine Lösung erstellt:
http://www.clever-excel-forum.de/thread-...l#pid47946

Gruß Ralf

[Crazy Tom]

Hi

hier deine gewünschte Ergänzung

Code:

Sub test()
   Dim lngZiel As Long
   Do
       lngZiel = Cells(Rows.Count, 18).End(xlUp).Row + 1
       If Cells(lngZiel, 17).Value = "xyz" Then
           Cells(lngZiel, 1).Resize(9, 1).EntireRow.Delete
       Else
           Cells(lngZiel + 1, 17).Resize(8, 1).Copy
           Cells(lngZiel, 18).PasteSpecial Paste:=xlPasteAll, Transpose:=True
           Cells(lngZiel + 1, 1).Resize(8, 1).EntireRow.Delete
       End If
   Loop While Cells(lngZiel + 1, 17) <> ""
End Sub

ich habe dir mal meine Testdatei angehangen
ich hoffe ich habe deine Zielvorstellung richtig verstanden

MfG Tom

[Dude85]

Hi Tom

Ja, funktioniert super!
Ich danke dir herzlichst für den Support - klasse!

Gruss
Urs

PS: auch Ralf für den Hinweis mit der Formel