AW: Makro Bestimmte Zeilen in andere Tabelle kopieren
20.09.2016 07:07:03
baschti007
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