VB Copia Foglio Excel senza Formule .... senza Copiare Pulsante Macro

Buon Giorno a tutti

sono nuovamente a chiedere aiuto ....

utilizzo un codice VB  creato dal Grande Norman Jones ...che nuovamente ringrazio , ...per copiare un singolo Foglio di excel da una cartella , in un altro Unico ,senza riportare ;Formule e collegamenti .................. Funziona perfettamente !!!  pero' Copia  Anche il Pulsante che fa' partire l'evento ...con il suo collegamento alla Macro , .... per cui una volta salvato il nuovo Foglio , bisogna Tagliare il Pulsante per interrompere i collegamenti ......

Esiste un modo per evitare questo evento ???

Una soluzione palliativa l'ho gia' individuata , Posizionare il Pulsante in Altro Foglio della Cartella di lavoro ...sostituendo nel codice 

With Activesheet  ..... il nome del Foglio interessato .... pero'  questo rende complicate le operazioni .. i fogli dove dovrei inserire i pulsanti sono 14 ... e vorrei evitare di dover passare continuamente da un foglio all'altro e inserire 14 macro (una per ogni pulsante ...)

il  codice e' il seguente

Dim VBC As Object

Dim p As String

Sub CopiaFoglio()

    ' Seleziona la cartella destinazione in DDir

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = DDir  '<<< Filtro per nome

        .Title = "Scegli la directory per il foglio " & ActiveSheet.Name

        .Show

        If .SelectedItems.Count = 0 Then    'directory non scelta

            MsgBox ("Scelta non effettuata, procedura abortita")

            Exit Sub

        End If

        DDir = .SelectedItems(1) & ""

    End With

    'Copia il foglio in un'altro al volo

    'Converte tutte le formule del foglio nel

    'valore al momento calcolato

    ActiveSheet.Copy

    Cells.Select

    Selection.Copy

    Cells.Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    Application.CutCopyMode = False

    Range("A1").Select

    ' Salva il foglio

    NewFName = DDir & FPrefix & ActiveSheet.Name & ".xlsx"

    ActiveWorkbook.SaveAs Filename:=NewFName

    ActiveWorkbook.Close

    With ActiveWorkbook.VBProject

    For Each VBC In .VBComponents

    If VBC.Type = 100 Then

    With VBC.CodeModule

    .DeleteLines 1, .CountOfLines

    .CodePane.Window.Close

    End With

    End If

    Next VBC

    End With

End Sub

               Grazie       Claudio P