Die Datei https://www.herber.de/bbs/user/1959.xls wurde aus Datenschutzgründen gelöscht
( 44 Kb )
Option Explicit
Sub zeilen_verbinden()
Dim sp As Integer
Dim s As Integer
Dim st As Integer
Dim ss As Integer
Dim ende As Integer
st = Worksheets("Tabelle1").Range("A1").End(xlDown).Row
ende = Worksheets("Tabelle1").Range("A5000").End(xlUp).Row
For s = st To ende
For sp = 2 To 8
Worksheets("Tabelle2").Cells(2 + ss, 1) = Worksheets("Tabelle1").Cells(st, 1)
Worksheets("Tabelle2").Cells(2 + ss, sp) = Worksheets("Tabelle1").Cells(st, sp)
Worksheets("Tabelle2").Cells(2 + ss, sp + 7) = Worksheets("Tabelle1").Cells(st + 1, sp)
Worksheets("Tabelle2").Cells(2 + ss, sp + 14) = Worksheets("Tabelle1").Cells(st + 2, sp)
Next sp
ss = ss + 1
If st = ende Then Exit For
st = Worksheets("Tabelle1").Range("A" & st).End(xlDown).Row
Next s
End Sub
Option Explicit
Sub zeilen_verbinden()
' Variablen deklarieren
Dim sp As Integer ' Schleifenzähler für Datenübertrag (Spalten)
Dim s As Integer ' Schleifenzähler für Datenübertrag (Zeilen)
Dim st As Integer ' Aktuelle Zeile
Dim ss As Integer ' Hilfsvariable für Datenausgabe
Dim ende As Integer ' Letzter Eintrag Spalte A
' Inhalte an Variablen zuweisen
st = Worksheets("Tabelle1").Range("A1").End(xlDown).Row ' erster Eintrag Spalte A
ende = Worksheets("Tabelle1").Range("A5000").End(xlUp).Row ' letzter Eintrag in Spalte A
' Daten übertragen
For s = st To ende ' Schleifenstart (Zeilen)
For sp = 2 To 8 ' Schleifenstart (Spalten)
Worksheets("Tabelle2").Cells(2 + ss, 1) = _
Worksheets("Tabelle1").Cells(st, 1) ' Kundennummer übertragen
Worksheets("Tabelle2").Cells(2 + ss, sp) = _
Worksheets("Tabelle1").Cells(st, sp) ' Daten aus 1. Zeile übertragen
Worksheets("Tabelle2").Cells(2 + ss, sp + 7) = _
Worksheets("Tabelle1").Cells(st + 1, sp) ' Daten aus 2. Zeile übertragen
Worksheets("Tabelle2").Cells(2 + ss, sp + 14) = _
Worksheets("Tabelle1").Cells(st + 2, sp) ' Daten aus 3. Zeile übertragen
Next sp ' Schleifenzähler plus 1 (Spalten)
ss = ss + 1 ' Zähler für Augabezeile plus 1
If st = ende Then Exit For ' Wenn Tabellenende erreicht, Ausstieg aus Schleife
st = Worksheets("Tabelle1").Range("A" & st).End(xlDown).Row ' Position der nächsten Kundennummer auslesen
Next s ' Schleifenzähler plus 1 (Zeilen)
End Sub