Copia singolo foglio excel 2010 senza copiare anche i collegamenti delle formule e salva in nuova cartella

Question

Buon giorno a tutti

innanzi tutto  voglio ringraziare questa community perche' ho riscontrato che funziona ...davvero

detto  questo  passo alla questione 

Avendo creato una cartella di svariati fogli di excel legati  tra loro con formule tipo cerca.vert   e  =se(   che  vanno a prendersi dati (con parecchio testo ) da altri fogli per riportarli nelle celle di destinazione ,     mi  sono  accorto che quando vado a salvarli ....innanzi tutto mi  salva l'INTERA  CARTELLA (tutti i fogli di quel file...) e poi , quando sono riuscito a trovare nei vari siti un codice VB un comando che mi permetteva di copiare il singolo foglio (activesheet ....) , SE lo trasmettevo ad altri loro aprendolo , trovavano ....#RIF!   ....ND  ( collegamenti delle formule mancanti..)

Ho trovato la soluzione (assemblando vari codici trovati in internet ...)  di  cui allego sotto codice  VB  FUNZIONANTE !!!!

copia singolo foglio in nuova cartella senza riportare collegamenti formule  e Macro , leggibile per chi lo riceve !!!!!  .

MACRO FUNZIONANTE  COPIA  SINGOLO FOGLIO EXCEL  SENZA  FORMULE  RIPORTANDO  TUTTI  I DATI DI TESTO  (PERFETTO)

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

L'unico  neo  e'  che  non e' possibile rinominare il  file direttamente dalla Macro (FileDialogPicker),bisogna farlo manualmente una volta salvato il foglio...

non e' un dramma MA ....... Qualcuno conosce una  soluzione (Magari inserendo un codice all'interno di tutta la routine ....) ????  .

GRAZIE  A  TUTTI                          Claudio

Answer 1

Ciao Claudio,

Reinterpretando la tua richiesta, sostituisci il mio codice precedente con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub CopiaFoglio()

    Dim DDir As String

    Dim FPrefix As String

    Dim NewFName As String

    Dim vName As Variant

    Dim VBC As VBComponent

    '\ Seleziona la cartella destinazione in DDir

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = vbNullString

        .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

    vName = Application.InputBox(Prompt:="Inserisci un nome per il nuovo file", _

                                 Default:=ActiveSheet.Name, _

                                 Title:="NUOVO NOME")

    '\ Richiedi il nome del nuovo file che verrà creato

    If vName = False Then

        Call MsgBox(Prompt:="Hai cancellato. Riprova!", _

                    Buttons:=vbCritical, _

                    Title:="MACRO TERMINATO!")

        Exit Sub

    End If

    '\ Crea un nuovo workbook (con un solo foglio) dal foglio attivo

    ActiveSheet.Copy

    '\ Converte tutte le formule del foglio del nuovo workbook

    '\ alle sue valore

    With ActiveSheet.UsedRange

        .Value = .Value

    End With

    '\ Salva il nuovo workbook

    NewFName = DDir & FPrefix & vName & ".xlsx"

    With ActiveWorkbook

        .SaveAs FileFormat:=51, Filename:=NewFName

        .Close SaveChanges:=False

    End With

    '\Cancella il codice di evento dal file originale

    With ThisWorkbook.VBProject

        For Each VBC In .VBComponents

            With VBC

                If .Type = 100 Then

                    With .CodeModule

                        .DeleteLines 1, .CountOfLines

                        .CodePane.Window.Close

                    End With

                End If

            End With

        Next VBC

    End With

End Sub

'<<=========

===

Regards,

Norman

Answer 2

Ciao Claudio,

Se ho captito la tua intenzione, forse prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub CopiaFoglio()

    Dim DDir As String

    Dim FPrefix As String

    Dim NewFName As String

    Dim vName As Variant

    Dim VBC As VBComponent

    '\ Seleziona la cartella destinazione in DDir

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = vbNullString    ' 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

    vName = Application.InputBox(Prompt:="Inserisci un nome per il nuovo file", _

                                 Default:=ActiveSheet.Name, _

                                 Title:="NUOVO NOME")

    If vName = False Then

        Call MsgBox(Prompt:="Hai cancellato. Riprova!", _

                    Buttons:=vbCritical, _

                    Title:="MACRO TERMINATO!")

        Exit Sub

    End If

    '\ Copia il foglio in un'altro al volo

    '\ Converte tutte le formule del foglio nel

    '\ valore al momento calcolato

    With ActiveSheet

        .Copy

        With .UsedRange

            .Value = .Value

        End With

    End With

    '\ Salva il foglio

    NewFName = DDir & FPrefix & vName & ".xlsx"

    With ActiveWorkbook

        .SaveAs FileFormat:=51, Filename:=NewFName

        .Close SaveChanges:=False

    End With

    With ThisWorkbook.VBProject

        For Each VBC In .VBComponents

            With VBC

                If .Type = 100 Then

                    With .CodeModule

                        .DeleteLines 1, .CountOfLines

                        .CodePane.Window.Close

                    End With

                End If

            End With

        Next VBC

    End With

End Sub

'<<=========

===

Regards,

Norman

Answer 3

Grazie  Grazie  Grazie   adesso  lo  provo ...

Tra l'altro in  merito al codice che mi avevi realizzato (aggiungi  righe identiche su foglio excel ....

Ho  smanettato un po' (salva con nome ...poi l'ho fatto convertire a excel 2010)  e  adesso ...FUNZIONA

PERFETTO !!!!!!

Non so' come ma se sara' possibile spero di ricambiare  !!!   Grazie di nuovo

                        Claudio

Answer 4

... e salvando come xlsx spazzola via il progetto VBA.

(Ciao Mauro!)

Answer 5

quando sono riuscito a trovare nei vari siti un codice VB un comando che mi permetteva di copiare il singolo foglio (activesheet ....) , SE lo trasmettevo ad altri loro aprendolo , trovavano ....#RIF!   ....ND  ( collegamenti delle formule mancanti..)

<cut>

Domanda mia: ma copiare e incollare solo i VALORI del foglio di origine nel nuovo foglio dell'altro file? E non ho capito nel tuo codice cosa devi rinominare.