[Spirosgr]

Καλημέρα
Βάλε τον παρακάτω κώδικα, στο κουμπί.

Private Sub CommandButton1_Click()
    Dim rngStart    As Range
    Dim rngDest     As Range
    Dim CellDest    As Range
    Set rngStart = ThisWorkbook.Sheets("1 ΙΣΤΟΡΙΚΟ").Range("at3:at18")
    Set rngDest = ThisWorkbook.Sheets("2 ΘΕΡΑΠΕΙΑ").Range("a29:a44")
    Set CellDest = ThisWorkbook.Sheets("2 ΘΕΡΑΠΕΙΑ").Range("a29")

    Application.ScreenUpdating = False

    rngDest.ClearContents
    rngStart.Copy
    CellDest.PasteSpecial Paste:=xlPasteValues

    Application.CutCopyMode = False
End Sub 

Η διόρθωση, έγινε με βάση αυτά που βλέπω (περιοχές, φύλλα, copy-paste αντί ένα loop κλπ)
Θεωρώ, ότι πρέπει να μεταφέρει τιμές και όχι συνάρτηση.