Makro Bestimmte Zeilen in andere Tabelle kopieren

So nun mal noch Datei mit hochgeladen-
https://www.herber.de/bbs/user/108275.zip
Teil 1 geht- also ausgewählte Zellen der Tabelle1 in neue Tabelle "Bearbeiten" Kopieren... nun soll es auch wieder zurück gehen!
also nach Änderungen auf der Tabelle "Bearbeiten" sollen diese wieder in den Zellen der "Tabelle1" nach folgenden Muster eingefügt werden.
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 der Tabelle"Bearbeiten" nach "Tabelle1" und Start bei 20
Zeile 31-60 " Start bei 69
Zeile 61-90 " Start bei 118
bis 5000 kopieren.
Kann jemand nachhelfen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Und wenn du meine Lösung von gestern nicht versucht hast bist du selber schuld =D
Hier noch mal die beiden Lösungen von Gestern ;)


Sub Von_Tabelle1_nach_Bearbeitung()
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 = 1
StartZeile = 20
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
Zeile2 = Zeile2 + arr(x) - 1 + y
If Not x Mod 2  0 Then
Ws1.Rows(Zeile & ":" & Zeile2).EntireRow.Copy
Ws2.Cells(last, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
last = last + arr(x)
End If
Zeile = Zeile + arr(x)
y = 1
If x = UBound(arr) Then x = 0: GoTo xx
x = x + 1
xx:
Loop
Application.ScreenUpdating = True
End Sub


Sub Von_Bearbeitung_nach_Tabelle1()
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

Gruß Basti

Beliebteste Forumthreads (12 Monate)

Makro Bestimmte Zeilen in andere Tabelle kopieren

3
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

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

318 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread