Nächsten freie Zelle

mit folgendem Programm

Private Sub CommandButton1_Click()

Range("A1").Select
Do While ActiveCell.Value <> Empty
ActiveCell.Offset(1, 0).Select
Loop

ActiveSheet.Paste

End Sub

suche ich in Spalte A die nächste freie Zelle.
Dann füge ich hier einen Wert ein.
Später speicher ich dieses ab. So weit so gut.
Mitlerweile bin ich in Zeile 3000 angekommen.
Das suchen der nächsten freien Zelle dauert immer, immer länger.

Ich helfe mir indem ich den Befehl Range("A1").Select in Range("A3000").Select ändere.

Gibt es eine andere Möglichkeit indem das Programm sich die letzte beschriebene Zeile merkt und da dann beim nächsten Mal weitermacht??

Danke

Norbert