Zeilen kopieren mit verschieden Endungen

[sandjar]

KLAPPT JETZT !! DANK!!

[WillWissen]

So?

Arbeitsblatt mit dem Namen 'Tabelle1'
	E	F	G
2	Art.-Nr NEU
3	a-s	KLEID1	10
4	a-m	KLEID1	10
5	a-l	KLEID1	10
6	b-s	KLEID2	10
7	b-m	KLEID2	10
8	b-l	KLEID2	10
9	c-s	KLEID3	10
10	c-m	KLEID3	10
11	c-l	KLEID3	10
12	d-s	KLEID4	10
13	d-m	KLEID4	10
14	d-l	KLEID4	10
15	e-s	KLEID5	10
16	e-m	KLEID5	10
17	e-l	KLEID5	10
18

Zelle	Formel
F3	=WENNFEHLER(INDEX($B$3:$B$7;ZEILE()/3);"")
G3	=WENNFEHLER(INDEX($C$3:$C$7;ZEILE()/3);"")

Verwendete Systemkomponenten: [Windows (32-bit) NT 10.00] MS Excel 2016

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

[sandjar]

..ich bins nochmal!!

..wie kann ich Deinen Quellcode so erweitern,  dass noch die Grössen XL und XXL dazugefügt werden?

Danke Dir

[MisterBurns]

So...

Code:

Sub Umschreiben()
Dim i As Long, last As Long

last = Cells(Rows.Count, 1).End(xlUp).Row

For i = last To 2 Step -1
  Rows(i + 1 & ":" & i + 4).Insert shift:=xlDown
  Rows(i).Copy
  Rows(i + 1 & ":" & i + 4).PasteSpecial Paste:=xlAll
  Cells(i, 1) = Cells(i, 1) & "-s"
  Cells(i + 1, 1) = Cells(i + 1, 1) & "-m"
  Cells(i + 2, 1) = Cells(i + 2, 1) & "-l"
  Cells(i + 3, 1) = Cells(i + 3, 1) & "-xl"
  Cells(i + 4, 1) = Cells(i + 4, 1) & "-xxl"
Next

End Sub

Für eventuelle weitere Größen vergleiche die beiden Codes Zeile für Zeile miteinander, dann schaffst du es auch, diese hinzuzufügen.