Makro letzte vorhandene Zeile kopieren und Nr. fortsetzen

Question

Hallo liebe COmmunity,

ich habe ein Problem mit dem ich einfach nicht weiterkomme.

Ich möchte in meiner Excel immer die letzte vorhandene Zeile inkl. Formatierungen und ggf. Formeln kopieren und darunter einsetzen (Spalte A-R). Außerdem ist in der Spalte A eine laufende Nr. die fortgesetzt werden muss.

Bei der Forum-Suche bin ich bereits auf ein Makro gestoßen, dass meine Forderungen fast komplett erfüllt. Nur kopiert das Makro leider anschließend alle Zeilen bis Nr. 598. Ich will aber einfach nur das eine Zeile in die nächste freie Zeile kopiert wird. Leider weiß ich nicht wie ich das Makro dahingehend umschreiben kann.

Hier der Link: https://supportnet.de/t/2418885

Hier ist das Makro:

Private Sub Workbook_Open()
Dim lngLetzte As Long
Dim lngZeile As Long
Dim azeile, zeile, lnummer As Long
Dim myRange As Range

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False


With Worksheets("Erledigt")
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count) + 1
End With
With Worksheets("Übersicht")
For lngZeile = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count) To 2 Step -1
If .Cells(lngZeile, 13) >= 1 Then
.Range(.Cells(lngZeile, 1), .Cells(lngZeile, 21)).Cut Worksheets("Erledigt").Cells(lngLetzte, 1)
.Rows(lngZeile).Delete
lngLetzte = lngLetzte + 1
End If
Next lngZeile
End With

'ab hier werden in der Tabelle Übersicht die Zeilen ergänzt
'höchste Zahl im Bereich zwischen A2 und A598 ermitteln
Set myRange = Worksheets("Übersicht").Range("A2:A598")
lnummer = Application.WorksheetFunction.Max(myRange)

'letzte Zeile mit einem Zahleneintrag in Spalte A ermitteln bzw. erste Zelle in der keine Zahl steht
For azeile = 2 To 598
If Worksheets("Übersicht").Cells(azeile, 1) = 0 Then Exit For
Next azeile

'Falls alle Zellen bis 598 eine Zahl beinhalten wird hier das Makro verlassen
If azeile = 599 Then Exit Sub

'Die Zellen mit den Formeln, Spalten B bis T werden bis Zeile 598 kopiert
For zeile = azeile To 598
'Zeile Einfügen
Worksheets("Übersicht").Rows(zeile).Insert Shift:=xlDown

'neue Nummer einfügen: höchste Nummer plus 1
lnummer = lnummer + 1
Worksheets("Übersicht").Cells(zeile, 1) = lnummer

'Spalten B bis T kopieren
Worksheets("Übersicht").Range(Cells(azeile - 1, 2), Cells(azeile - 1, 20)).Copy Worksheets("Übersicht").Range("B" & zeile)
Next zeile

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True


End Sub


Kann mir da einer helfen? Bin wirklich am verzweifeln...

Danke und Grüße
Alex

Answer 1

Hallo Alex,

meinst du das etwa so:

Sub letzte_zeile_kopieren()

Dim lzeile As Long

lzeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

'letzte Zeile kopieren
ActiveSheet.Range(Cells(lzeile, 2), Cells(lzeile, 20)).Copy Destination:=ActiveSheet.Cells(lzeile + 1, 2)

'höchste Zahl in bisherigen Zeilen ab Zeile 1 ermitteln, um 1 erhöhen und in Spalte A der neuen Zeile schreiben
ActiveSheet.Cells(lzeile + 1, 1) = Application.WorksheetFunction.Max(Range(Cells(1, 1), Cells(lzeile, 1))) + 1

End Sub

Gruß

M.O.

Answer 2

Hab das Ganze mal etwas zusammengekürzt:

Private Sub runterkopieren()
Dim lngLetzte As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False


With Worksheets(1)
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
End With
Worksheets(1).Range(Cells(lngLetzte, 2), Cells(lngLetzte, 20)).Copy Worksheets(1).Range("B" & lngLetzte + 1)
Worksheets(1).Cells(lngLetzte + 1, 1) = Worksheets(1).Cells(lngLetzte, 1) + 1
Application.ScreenUpdating = True

End Sub

Gruß
Kauz