Kopieren und Einfügen

Sub Copy_Click() ' Funktion Kopieren und Einügen Application.ScreenUpdating = False Dim rueck As Worksheet Dim rng As Range If vbYes = MsgBox("Are you sure to file these data?", vbDefaultButton1 + vbYesNo + _ vbInformation, "Attention!") Then Set rueck = ActiveSheet With rueck.Shapes(Application.Caller) Set rng = Range(.TopLeftCell.Offset(-1).Row & ":" & .TopLeftCell.Offset(11).Row).Rows End With With Sheets("Tasker Archive") rng.Copy Destination:=.Range("A" & .Cells.SpecialCells(xlLastCell).Row + 1) End With Application.CutCopyMode = False rng.Resize(1).ClearContents rng.Resize(10).Offset(3).ClearContents End If Set rng = Nothing Set rueck = Nothing Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Kopieren und Einfügen

09.12.2020 14:19:13

Werner

AW: Kopieren und Einfügen

09.12.2020 14:33:27

Florian

AW: Kopieren und Einfügen

09.12.2020 15:01:41

Edmund

AW: Kopieren und Einfügen

09.12.2020 15:06:00

Werner

AW: Kopieren und Einfügen

09.12.2020 15:50:14

Florian

AW: Kopieren und Einfügen

09.12.2020 16:07:05

Werner

AW: Kopieren und Einfügen

10.12.2020 16:07:19

Florian

AW: Kopieren und Einfügen

11.12.2020 00:50:01

Werner

Korrektur

11.12.2020 01:02:50

Werner

AW: Korrektur

11.12.2020 12:42:20

Florian

AW: Korrektur

11.12.2020 13:05:45

Werner

AW: Korrektur

11.12.2020 13:21:30

Florian

AW: Korrektur

11.12.2020 13:42:18

Werner

AW: Korrektur

11.12.2020 14:28:06

Florian

AW: Korrektur

11.12.2020 14:29:11

Werner

AW: Korrektur

14.12.2020 16:35:39

Florian

AW: Korrektur

15.12.2020 05:51:59

Werner

AW: Korrektur

15.12.2020 09:52:15

Florian

AW: Korrektur

15.12.2020 10:23:38

Werner

AW: Korrektur

15.12.2020 10:41:04

Florian

AW: Korrektur

15.12.2020 10:45:30

Werner

AW: Korrektur

15.12.2020 10:58:38

Florian

Gerne u. Danke für die Rückmeldung. o.w.T.

15.12.2020 11:17:10

Werner

Sub Copy_Click() ' Funktion Kopieren und Einügen Dim rng As Range, loLetzteZiel As Long Application.ScreenUpdating = False If MsgBox("Are you sure to file these data?", vbDefaultButton1 + vbYesNo + _ vbInformation, "Attention!") = vbYes Then With ActiveSheet.Shapes(Application.Caller) Set rng = Range(.TopLeftCell.Offset(-1).Row & ":" & .TopLeftCell.Offset(11).Row).Rows End With With Worksheets("Tasker Archive") loLetzteZiel = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row If loLetzteZiel = 3 Then loLetzteZiel = 5 rng.Copy Destination:=.Range("A" & loLetzteZiel) End With rng.Resize(1).ClearContents rng.Resize(10).Offset(3).ClearContents End If Application.CutCopyMode = False Set rng = Nothing End Sub

Sub Copy_Click() ' Funktion Kopieren und Einügen Dim rng As Range, loLetzteZiel As Long Application.ScreenUpdating = False If MsgBox("Are you sure to file these data?", vbDefaultButton1 + vbYesNo + _ vbInformation, "Attention!") = vbYes Then With ActiveSheet.Shapes(Application.Caller) Set rng = Range(.TopLeftCell.Offset(-1).Row & ":" & .TopLeftCell.Offset(11).Row).Rows End With With Worksheets("Tasker Archive") loLetzteZiel = .UsedRange.Row + .UsedRange.Rows.Count If loLetzteZiel = 3 Then loLetzteZiel = 5 rng.Copy Destination:=.Range("A" & loLetzteZiel) End With rng.Resize(1).ClearContents rng.Resize(10).Offset(3).ClearContents End If Application.CutCopyMode = False Set rng = Nothing End Sub

Hallo,
ist ja logsich.
Du ermittelst im Zielblatt die letzte belegte Zelle in Spalte A. Und wenn in deiner ursprünglichen Liste nur eine Zeile mit Daten befüllt war, dann wird beim nächsten Vorgang der kopierte Bereich unter dieser befüllten Zelle eingefügt. Und das ist dann halt nun mal nicht dein gewünschtes Ende.
Umgehen kannst du das z.B. indem du dafür sorgst, dass in deiner Ursprungstabelle die Zelle A17 immer befüllt ist. Dann passt auch die Ermittlung der letzten belegten Zelle im Zielblatt.
Hier im Code wird jetzt nach dem Einfügen geprüft, ob die letzte Tabellenzelle in Spalte A leer ist oder nicht.
Ist sie nicht leer, dann wird nichts gemacht.
Ist sie leer, dann wird dort ein x eingetragen und die Schriftfarbe auf weiß gesetzt, daß man das nicht sieht.
Auf alle Fälle ist damit sichergestellt, dass die letzte Zelle in Spalte A immer einen Wert hat. Dann passt auch die Ermittlung für den Einfügevorgang.

Sub Copy_Click() ' Funktion Kopieren und Einügen
Dim rng As Range, loLetzteZiel As Long
Application.ScreenUpdating = False
If MsgBox("Are you sure to file these data?", vbDefaultButton1 + vbYesNo + _
vbInformation, "Attention!") = vbYes Then
With ActiveSheet.Shapes(Application.Caller)
Set rng = Range(.TopLeftCell.Offset(-1).Row & ":" & .TopLeftCell.Offset(11).Row).Rows
End With
With Worksheets("Tasker Archive")
loLetzteZiel = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
If loLetzteZiel = 3 Then loLetzteZiel = 5
rng.Copy Destination:=.Range("A" & loLetzteZiel)
If .Cells(loLetzteZiel, "A").Offset(12) = "" Then
.Cells(loLetzteZiel, "A").Offset(12) = "x"
.Cells(loLetzteZiel, "A").Offset(12).Font.Color = vbWhite
End If
End With
rng.Resize(1).ClearContents
rng.Resize(10).Offset(3).ClearContents
End If
Application.CutCopyMode = False
Set rng = Nothing
End Sub

Gruß Werner

Das funktioniert hervorragend. Eben weil ich auch die Gruppierung beibehalten kann nach der Archivierung. Vielen DANK!
Aber ich Frage habe ich noch. Ich möchte nun die archievierten Einträge aus dem Tasker Archive auch seperat über einen button löschen können. Wie kann ich die Zeilen variabel ansprechen, um das Macro für mehrere Buttons nutzen zu können? Hoffe du verstehst was ich meine?
Ich möchte den archivierten Beitrag A5:I17 löschen
Meine Idee ist die Zeilen 5:17 über einen button zu löschen.
Ich möchte aber das die Funktion automatisch auf andere zellen angepasst wird,
wenn ich zb einen Button für den archivierten Beitrag A96:A108 erstelle um diesen zu löschen und das Makro zuweise.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column = 1 Then If Target.Cells(1, 1) = "Storyboard" Then Cancel = True If MsgBox("Are you sure to delete these data?", vbDefaultButton1 + vbYesNo + _ vbInformation, "Attention!") = vbYes Then Target.Offset(-1).Resize(13).EntireRow.Delete End If End If End If End Sub

Sub Copy_Click() Dim rng As Range, last As Long Application.ScreenUpdating = False If vbYes = MsgBox("Are you sure to file these data?", vbDefaultButton1 + vbYesNo + _ vbInformation, "Attention!") Then With ActiveSheet.Shapes(Application.Caller) Set rng = Range(.TopLeftCell.Offset(-1).Row & ":" & .TopLeftCell.Offset(11).Row).Rows End With With Worksheets("Tasker Archive") last = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row If last = 3 Then last = 5 rng.Copy Destination:=.Range("A" & last) If .Cells(last, "A").Offset(12) = "" Then .Cells(last, "A").Offset(12) = "x" .Cells(last, "A").Offset(12).Font.Color = vbWhite End If End With rng.Resize(1).ClearContents rng.Resize(10).Offset(3).ClearContents End If Application.CutCopyMode = False Set rng = Nothing Application.ScreenUpdating = True End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim loLetzteZiel As Long Application.ScreenUpdating = False If Target.Cells(1, 1).Address(0, 0) = "A6" Then Cancel = True If MsgBox("Are you sure to file these data?", vbDefaultButton1 + vbYesNo + _ vbInformation, "Attention!") = vbYes Then Target.Offset(-1).Resize(13, 9).Copy With Worksheets("Tasker Archive") loLetzteZiel = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row If loLetzteZiel = 3 Then loLetzteZiel = 5 .Cells(loLetzteZiel, "A").PasteSpecial Paste:=xlPasteAll If .Cells(loLetzteZiel, "A").Offset(12) = "" Then .Cells(loLetzteZiel, "A").Offset(12) = "x" .Cells(loLetzteZiel, "A").Offset(12).Font.Color = vbWhite End If End With Target.Offset(2).Resize(10, 9).ClearContents End If End If Application.CutCopyMode = False End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Then If Target.Row > 4 And Target.Count = 1 Then If Target.Offset(1).Cells(1, 1) = "Storyboard" Then Target.Offset(12, 4) = IIf(Target "", Target, "") End If End If End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Then If Target.Row > 4 And Target.Count = 1 Then If Target.Offset(1).Cells(1, 1) = "Storyboard" Then Target.Offset(12, 4) = IIf(Target "", Date, "") End If End If End If End Sub

Sub Workbook_Open() Worksheets("Tasker").Protect userinterfaceonly:=True, Password:="Passwort" Worksheets("Tasker").EnableOutlining = True Worksheets("Tasker Archive").Protect userinterfaceonly:=True, Password:="Passwort" End Sub

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kopieren und Einfügen

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread