Kopier code verbessern

[AlterDresdner]

Hallo Jürgen,
anbei eine korrigierte Fassung. Das zeilenweise Kopieren ist nicht optimal, aber zunächst besser nachvollziehbar.
Der Code lautet
Option Explicit 'ist wichtig, entdeckt Schreibfehler
Sub Übertragen()
'
' Übertragen Makro
Dim LastRow As Long, Aktrow As Long
  Application.ScreenUpdating = False 'um Bildschirmflackern zu vermeiden
    LastRow = Sheets("Verzehr_Jahresübersicht").Cells(Rows.Count, 1).End(xlUp).Row + 1
    'erste freie Zeile in Verzehr_Jahresübersicht
    'aus Tagesblatt oberer Bereich Kopieren
    Aktrow = 3
    While IsDate(Cells(Aktrow, 10)) 'solange J mit Datum belegt
      Cells(Aktrow, 10).Resize(, 36).Copy
      Sheets("Verzehr_Jahresübersicht").Cells(LastRow, 1).PasteSpecial Paste:=xlPasteValues
      LastRow = LastRow + 1
      Aktrow = Aktrow + 1
    Wend
    'Tagesblatt unterer Bereich Kopieren
    Aktrow = 22
    While IsDate(Cells(Aktrow, 10)) 'solange J mit Datum belegt
      Cells(Aktrow, 10).Resize(, 36).Copy
      Sheets("Verzehr_Jahresübersicht").Cells(LastRow, 1).PasteSpecial Paste:=xlPasteValues
      LastRow = LastRow + 1
      Aktrow = Aktrow + 1
    Wend
        ' Kopieren beenden
    Application.CutCopyMode = False
   
    ' Hilfsfunktion wir wieder gelöscht
   
    Sheets("Tagesblatt").Select

    Range("b1").Value = Range("b1").Value + 1
    Range("K3:AP20,K22:AP35,AR3:AS20,AR22:AS35").Select
    Range("AR22").Activate
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("K3").Select
  Application.ScreenUpdating = True 'wieder einschalten
End Sub