Makro, um an das Ende einer Liste zu springen

Question

Hallo SN User,

ich suche ein Makro, mit dem ich an das Ende einer Liste springen kann.

Ausgangslage
Ich habe eine Spalte (A), in die Einträge jeweils nur für den aktuellen Anlass eingetragen werden. Nachdem das Thema erledigt ist, sollen diese Einträge in einer anderen Spalte (C) "archiviert" werden, in dem sie an das Ende der in Spalte C bereits vorhandenen Einträge gefügt werden.

Beispiel
Spalte .A | Spalte B
Eintrag 4 | Eintrag 1
Eintrag 5 | Eintrag 2
................ | Eintrag 3

Die Anzahl der Einträge pro Durchgang kann unterschiedlich sein. In diesem Beispiel wurden bereits die Einträge 1-3 archiviert. Nun möchte ich die Einträge 4+5 aus Spalte A an das Ende der Spalte C anfügen.

Problem
Ich zeichne ein Makro auf:
1. Klick auf Zelle A1
2. Einträge 4+5 mit Strg+Shift+CurserDowndann markieren
3. Einträge mit Strg+x ausschneiden
4. Klick auf Zelle C1
5. Mit Strg+CurserDown auf den letzten Eintrag (Nr. 3) der Liste springen
6. Mit CurserDown in die Zelle unterhalb der Liste in Spalte C springen
7. Mit Strg+v den Inhalt einfügen

Der Code des Makros sieht dann wie folgt aus:

Sub Macro13()
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("C1").Select
Selection.End(xlDown).Select
Range("C4").Select
ActiveSheet.Paste
End Sub

vermutete Problemursache
Aus meiner Sicht rührt das Problem aus der Zeile Range("C4").Select im Code, weil dort ein fester Zellbezug auf Zelle C4 enthalten ist, wodurch auch bei zukünftigen Durchgängen die neuen Einträge ab C4 eingefügt werden.

Frage
Wie kann ich diesen festen Zellbezug umgehen und einfach ans Ende der Liste gelangen?

Danke vorab für Eure Vorschläge.
Gruß, Phlip

Answer 1

Hallo Philip,

Option Explicit

Sub Macro13()
Dim LoLetzte As Long
Dim LoLetzte2 As Long
LoLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
LoLetzte2 = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
Range(Cells(1, 1), Cells(LoLetzte, 1)).Copy Range("B" & LoLetzte)
Range(Cells(1, 1), Cells(LoLetzte, 1)).ClearContents
End Sub

Gruß Hajo

Answer 2

Hallo Philip,

oder etwas kürzer

Option Explicit

Sub Macro13()
Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Cut _
Range("C" & Cells(Rows.Count, 3).End(xlUp).Row + 1)
End Sub

Gruss
Rainer

Answer 3

Hallo Ihr beiden,

@Hajo: Danke für den Code und die schnelle Antwort. Dein Makro überschreibt mir aber immer die gleichen Zellen, so wie bei meinem ursprünglichen Problem.

@Rainer: Dein Code funktioniert. Jetzt möchte ich allerdings gerne die ausgeschnittenen Zellen auf ein separates Tabellenblatt "Archive" schreiben. Ich dachte, es geht wie folgt:

Sub Macro13()

Range("D5:D" & Cells(Rows.Count, 1).End(xlUp).Row).Cut _
Sheets("Archive").Select
Range("C" & Cells(Rows.Count, 6).End(xlUp).Row + 1)

End Sub

Wenn ich aber den Befehl Sheets("Archive").Select einfüge, wird automatisch ein Leerzeichen nach dem zweiten Range vor der Klammer eingfügt und eine Fehlermeldung ausgegeben, wenn ich das Makro laufen lasse.

Hast Du hierzu noch eine Idee?

Viele Grüße
Phlip

Answer 4

Hallo Philp,

es fehlte nr +1 und die Spalte war falsch. Von Unterschiedlichen Tabellenm Stand nichts im ersten Beitrag. Mit Ciut habe ich schon schlechte Erfahrung gemacht.

Option Explicit

Sub Macro13()
Dim LoLetzte As Long
Dim LoLetzte2 As Long
LoLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
With Worksheets("Tabelle2")
' kopieren in Spalte B
LoLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(Rows.Count, 2).End(xlUp).Row, .Rows.Count) + 1
Range(Cells(1, 1), Cells(LoLetzte, 1)).Copy .Range("B" & LoLetzte)
End With
Range(Cells(1, 1), Cells(LoLetzte, 1)).ClearContents
End Sub

Gruß Hajo

Answer 5

Hallo Philip,

ungetestet:

Option Explicit

Sub Macro13()
Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Cut _
Sheets("Archive").Range("C" & Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Row + 1)
End Sub

Gruss
Rainer

Answer 6

Hallo noch mal,

@Hajo: Die unterschiedlichen Tabellenblätter habe ich bei der Eingangsfrage bewusst weggelassen, um das Problem nicht zu sehr zu komplizieren. Auch dachte ich, dass ich den Befehl für das Wechseln des Tabellenblattes schon kannte und mir das dann selbst zurecht basteln könnte. Ich hing ja vor allem daran, dass ich keinen Zähler hinbekommen habe.

Deinen neuen Code habe ich getestet. Er überschreibt noch immer die Archivspalte. Dabei beginnt er in der Reihe, die der Anzahl von Einträgen in der neuen Spalte (A) entspricht.

Bsp.: Ich Spalte A habe ich 3 neue Einträge, in der Archivspalte bereits 7. Dann beginnt das Makro die Archivspalte ab Reihe 3 zu überschreiben, bei 4 neuen Einträgen überschreibt er ab Reihe 4 usw.

@Rainer: Funktioniert. :-)

Vielen Dank Euch beiden und einen schönen Abend.

@Foren admin: In Rainers letztem Beitrag sieht man, dass das "b" von End Sub fehlt. Ich hatte das gleiche Problem heute auch schon mal, als direkt hinter dem "b" der Befehl [ / c o d e ] stand. Fügt man nach dem "b" noch ein Leerzeichen ein, wird es mit abgebildet.

Gruß, Phlip

Answer 7

Hallo Philip,

Hier die Antwort auf Deine Frage per Pager.

[code]Option Explicit

Sub Macro13()
    Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Copy _
        Sheets("Archive").Range("C" & Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Row + 1)
    Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).ClearContents
End Sub
[/code]

Gruss
Rainer

Answer 8

Hi Rainer,
hi all,

vielen Dank. Das funktioniert.

Ich habe das jetzt für mehrere Spalten angewendet, wobei die Daten wie folgt von Tabellenblatt 1 zu Tabellenblatt "Archive" übertragen werden sollen:
Spalte B --> Spalte B
Spalte D --> Spalte C
Spalte F --> Spalte D

Sub Macro13()
Range("B5:B" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Copy _
Sheets("Archive").Range("B" & Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Row + 1)
Range("B5:B" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).ClearContents

Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Copy _
Sheets("Archive").Range("C" & Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Row + 1)
Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).ClearContents

Range("F5:F" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Copy _
Sheets("Archive").Range("D" & Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Row + 1)
Range("F5:F" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).ClearContents
End Sub

Der mittlere Block ist der, über den wir gesprochen haben. Die Blöcke darüber und darunter habe ich modifiziert (Austauschen der Zellbezüge), um weitere Daten auf das Tabellenblatt "Archive" zu übertragen.

Erstaunlicherweise funktioniert das beim unteren Block nicht richtig. Hier werden immer nur die Überschrift (soll nicht kopiert werden) und der erste Eintrag kopiert und auf dem Tabellenblatt "Archive" eine Zeile tiefer als der letzte archivierte Eintrag angezeigt.

Beispiel
Tabellenblatt 1 (Ausgangssituation):
Spalte B | Spalte D | Spalte F
Header1|Header2|Header3
W e rt 1 | W e r t 4 | Wert 7
W e rt 2 | W e r t 5 | Wert 8
W e rt 3 | W e r t 6 | Wert 9

Tabellenblatt "Archive" (Ergebnis):
Spalte B | Spalte C | Spalte D
HeaderA|HeaderB|HeaderC
W e rt 1 | W e r t 4 |
W e rt 2 | W e r t 5 |
W e rt 3 | W e r t 6 |
...............|.................| Header3
...............|.................| Wert 7

Wert 8 und Wert 9 werden nicht übertragen.

Tabellenblatt 1(Ergebnis):
Spalte B | Spalte D | Spalte F
Header1|Header2|
W e rt 1 | W e r t 4 |
W e rt 2 | W e r t 5 | Wert 8
W e rt 3 | W e r t 6 | Wert 9

Ich kann nicht nachvollziehen, warum es bei allen Blöcken funktioniert, nur beim letzten nicht.

Viele Grüße
Phlip

Answer 9

Hallo Philip,

da sind noch einige Fehler vorhanden.
So müsste es funktionieren.

Sub Macro13()
Range("B5:B" & ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row).Copy _
Sheets("Archive").Range("B" & Sheets("Archive").Cells(Rows.Count, 2).End(xlUp).Row + 1)
Range("B5:B" & ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row).ClearContents

Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Copy _
Sheets("Archive").Range("C" & Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Row + 1)
Range("D5:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).ClearContents

Range("F5:F" & ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row).Copy _
Sheets("Archive").Range("D" & Sheets("Archive").Cells(Rows.Count, 4).End(xlUp).Row + 1)
Range("F5:F" & ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row).ClearContents
End Sub

Gruss
Rainer

Answer 10

Hallo Rainer,

jetzt funktioniert es. Ein großes DANKESCHÖN.

Viele Grüße
Phlip