Makro Bestimmte Zeilen in andere Tabelle kopieren

Ist es auch in der Gegenrichtung möglich, mit einem Makro zusammenhängende Zeilen aus der dann geänderten Tabelle "Bearbeitung" die Daten der Zeilen als Werte in die bestehende "Tabelle1" zu Kopieren ohne deren Formatierung zu zerstören?
Also Zeilen 1-30 von Tabelle"Bearbeiten" nach Zeile 20 - 49 der "Tabelle1"
weiter " 31-60 " " " 69 - 98 "
weiter " 61-90 " " " 118- 147 "
weiter " 91-120 " " " 167- 196 "
und das ganze so weiter bis Zeile 5000 kopieren.
Kurz gesagt Zeile 1-30 nach andere Tabelle Start bei 20
Zeile 31-60 " Start bei 69
Zeile 61-90 " Start bei 118
bis 5000 kopieren.
Währe nicht schlecht wenn man da ein Makro zusammenbasteln kann. Gern auch mit Kommentare, das ich auch etwas nachvollziehen kann.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Nun ja ein bissel könnte man auch selber versuchen die lösung lag ja schon auf deiner hand ;)
Gurß Basti


Sub Gooa()
Dim Zeile As Long
Dim Zeile2 As Long
Dim StartZeile As Long
Dim last As Long
Dim arr
Dim x As Long
Dim y As Long
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets("Tabelle1")
Set Ws2 = ThisWorkbook.Worksheets("Bearbeitung")
Application.ScreenUpdating = False
last = 17 ' Start von Tabelle 1
StartZeile = 1 ' Start von Bearbeitung
x = 0
y = 0
arr = Array(33, 19, 30, 19) ' JA,NEIN,JA,NEIN
Zeile = StartZeile
Zeile2 = StartZeile
Do
If Zeile > 3120 Then Exit Do
If Not x Mod 2 <> 0 Then
Zeile2 = Zeile2 + arr(x) - 1 + y
Ws2.Rows(Zeile & ":" & Zeile2).EntireRow.Copy
Ws1.Cells(last, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False,  _
Transpose:=False
last = last + arr(x)
Zeile = Zeile + arr(x)
Else
last = last + arr(x)
End If
y = 1
If x = UBound(arr) Then x = 0: GoTo xx
x = x + 1
xx:
Loop
Application.ScreenUpdating = True
End Sub

Sub Gooa() Dim Zeile As Long Dim Zeile2 As Long Dim StartZeile As Long Dim last As Long Dim arr Dim x As Long Dim y As Long Dim Ws1 As Worksheet Dim Ws2 As Worksheet Set Ws1 = ThisWorkbook.Worksheets("Tabelle1") Set Ws2 = ThisWorkbook.Worksheets("Bearbeitung") Application.ScreenUpdating = False last = 20 ' Start von Tabelle 1 StartZeile = 1 ' Start von Bearbeitung x = 0 y = 0 arr = Array(30, 19, 30, 19) ' JA,NEIN,JA,NEIN Zeile = StartZeile Zeile2 = StartZeile Do If Zeile > 5000 Then Exit Do If Not x Mod 2 <> 0 Then Zeile2 = Zeile2 + arr(x) - 1 + y Ws2.Rows(Zeile & ":" & Zeile2).EntireRow.Copy Ws1.Cells(last, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=False last = last + arr(x) Zeile = Zeile + arr(x) Else last = last + arr(x) End If y = 1 If x = UBound(arr) Then x = 0: GoTo xx x = x + 1 xx: Loop Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Makro Bestimmte Zeilen in andere Tabelle kopieren

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

318 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro Bestimmte Zeilen in andere Tabelle kopieren

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

318 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread