Macro copia foglio attivo con nome e cancella celle

[Zagor57]

Buonasera
Ricorro ancora al vostro prezioso aiuto
con questa Macro:

Codice: Seleziona tutto

Sub SalvaPreventivo()
    myDir = "D:\Archivio Gruppo Bx\Preventivi tettoie"
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=myDir & "\" & Range("g12") & ".xls"
    ActiveWorkbook.Close
   
    End Sub

copio il foglio attivo con il nome della cella ( G12 )senza le macro ,mentre vorrei si copiasse anche le macro ,inoltre vorrei:
1) ritornare nel foglio attivo
2) Cancellare le celle che vanno da (G12:G42)
3) Salvare il foglio attivo
Grati per il vostro aiuto

[Anthony47]

Lascia stare la macro che ora usi e spiega da zero tutto quello che hai bisogno di fare, partendo dal file di originale.

Ciao

[Zagor57]

Ok Anthony......grazie per il tuo interessamento
cerco di essere il più chiaro possibile
ho costruito un file il cui nome è: ( Prenentivo Tettoie),dove attraverso conbinazioni di dati mi crea tutte le misure necessarie per la costruzione di tettoie in legno nonchè il preentivo stesso ,quello che vorrei fare e il seguente
una volta compilato tutti i dati devo salvare il nuovo file con tutte le formule e quant'altro vi è nel file originale,con il nome della cella in ( G12 ) nel percorso "D:\Archivio Gruppo Bx\Preventivi tettoie".<<<<---questo è il salvataggio del file............
Nel file originale ( che risiede nella stessa cartella )invece, nel foglio " MENU ", per una eventuale modifica o visione vorrei creare un collegamento al file appena salvato.<<<<<<------Nota i file potrebbero essere centinaia il che ognuno avrà il suo nome come da cella G12 di volta in volta..........
Dopo aver fatto cio sempre nel file origine deve cancellarmi tutti i dati inseriti precedentemente per preparare il file per un nuovo preventivo,le celle da cancellare sono le seguenti:

Codice: Seleziona tutto

 Application.Goto Reference:="R59C229"
    Selection.ClearContents
    Range("BY15:BZ15").Select
    Selection.ClearContents
    Range("BY17:BZ17").Select
    Selection.ClearContents

    Range("BY19:BZ19").Select
    Selection.ClearContents
    Range("BY21").Select
    Selection.ClearContents
    Range("BY22").Select
    Selection.ClearContents
    Range("BY25:BZ25").Select
    Selection.ClearContents
    Range("BY28:BZ28").Select
    Selection.ClearContents
    Range("BY30:BZ30").Select
    Selection.ClearContents
    Range("BY32:BZ32").Select
    Selection.ClearContents
    Range("BR33:BY33").Select
    Range("BY33").Activate
    Range("BY34").Select
    Selection.ClearContents
    Range("P34").Select
    Selection.ClearContents
     Range("P28").Select
    Selection.ClearContents
    Range("r38:R33").Select
    Selection.ClearContents
    Range("p38:P33").Select
    Selection.ClearContents
    Range("P29").Select
    Selection.ClearContents
    Range("n38:N33").Select
    Selection.ClearContents
    Range("N25").Select
    Selection.ClearContents
    Range("N21").Select
    Selection.ClearContents
    Range("L32:L18").Select
    Selection.ClearContents
    Range("L15").Select
    Selection.ClearContents
    Range("L16").Select
    Selection.ClearContents
    Range("N30").Select
    Selection.ClearContents
    Range("N29").Select
    Selection.ClearContents
    Range("N22").Select
    Selection.ClearContents
    Range("N18").Select
    Selection.ClearContents
    Range("G29").Select
    Selection.ClearContents
    Range("G28").Select
    Selection.ClearContents
    Range("G27").Select
    Selection.ClearContents
    Range("G26").Select
    Selection.ClearContents
    Range("G25").Select
    Selection.ClearContents
    Range("F24:G24").Select
    Selection.ClearContents
    Range("G23").Select
    Selection.ClearContents
    Range("G22").Select
    Selection.ClearContents
    Range("G21").Select
    Selection.ClearContents
    Range("G20").Select
    Selection.ClearContents
    Range("G18").Select
    Selection.ClearContents
    Range("G17").Select
    Selection.ClearContents
    Range("G16").Select
    Selection.ClearContents
    Range("G15").Select
    Selection.ClearContents
    Range("G14").Select
    Selection.ClearContents
    Range("G12:J12").Select
    Selection.ClearContents
    Range("N12").Select
    Selection.ClearContents
    Range("L14").Select
    Selection.ClearContents
    Range("G11:J11").Select
    Selection.ClearContents

una volta eseguito deve salvare il file

spero di essere stato chiaro

[Anthony47]

Prova se questa macro fa quello che dici:

Codice: Seleziona tutto

Sub Salvaprev()
Dim myPath As String, myName As String, myClear, I As Long, myExt As String
'
myPath = "D:\PIPPO\Prova1\"                 '<<< Il tuo path, completo di \ finale
'
myExt = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."), 99)
myName = myPath & Range("G12").Value & myExt
'
myClear = Array("HU59", "BY15:BZ15", "BY17:BZ17", "BY19:BZ19", "BY21", "BY22", "BY25:BZ25", "BY28:BZ28", "BY30:BZ30", _
    "BY32:BZ32", "BR33:BY33", "BY33", "BY34", "P34", "P28", "r38:R33", "p38:P33", "P29", "n38:N33", "N25", "N21", _
    "L32:L18", "L15", "L16", "N30", "N29", "N22", "N18", "G29", "G28", "G27", "G26", "G25", "F24:G24", "G23", "G22", _
    "G21", "G20", "G18", "G17", "G16", "G15", "G14", "G12:J12", "N12", "L14", "G11:J11")
Err.Clear
On Error Resume Next
ActiveWorkbook.SaveCopyAs Filename:=myName
If (Err.Number) <> 0 Then
RISPO = MsgBox("Errore creando il file " & myName & vbCrLf & _
        Err.Description & vbCrLf & vbCrLf & _
        "LA PROCEDURA VIENE INTERROTTA", vbCritical)
    Exit Sub
End If
On Error GoTo 0
RISPO = MsgBox("I dati variabili verranno cancellati!" & vbCrLf & "Si per continuare e cancellare, No per interrompere senza cancellare", vbYesNo + vbExclamation)
If RISPO <> vbYes Then
    MsgBox ("Il file non e' stato azzerato...")
    Exit Sub
End If
For I = LBound(myClear) To UBound(myClear)
    Range(myClear(I)).ClearContents
Next I
MsgBox ("Completato...")
End Sub

La riga marcata <<< va personalizzata col tuo percorso, completo di \ finale.
La macro salva una copia del tuo workbook corrente e poi azzera quell'elenco di range.

Ciao

[Zagor57]

Ciao Anthony
La macro funziona in parte: mi effettua perfettamente la copia ma....
nel cancellare il Range mi da errore-->>> Impossibile modificare una parte di cella unita <<<--- e nel Debug mi evidenzia

Range(myClear(I)).ClearContents

Il collegamento ipertestuale ai vari file salvati non c'è,che è la cosa che non sono riuscito a fare con il registratore di macro,mentre per il resto bene o male ci ero riuscito
ciao attendo una tua modifica grazie

[Anthony47]

Se vuoi sapere cosa penso delle celle unite leggi qui: viewtopic.php?f=26&t=85065
Cio' detto, prova nella tua macro a sostituire in blocco
For I = LBound(myClear) To UBound(myClear)
Range(myClear(I)).ClearContents
Next I

con

Codice: Seleziona tutto

For I = LBound(myClear) To UBound(myClear)
    Range(myClear(I)).Select
    Selection.ClearContents
Next I
Range("A1").Select

Il collegamento ipertestuale ai vari file salvati non c'è, che è la cosa che non sono riuscito a fare con il registratore di macro,mentre per il resto bene o male ci ero riuscito

Mi ero fermato alla domanda iniziale posta nel primo messaggio...

Per avere l'indice con hyperlink su foglio Menu', aggiungi questa macro:

Codice: Seleziona tutto

Sub myLink(ByVal mFile As String)
Dim iNext As Long, MenuSH As Worksheet, iCol As String
'
Set MenuSH = Sheets("MENU")         '<<< Il foglio con l'indice
iCol = "A"                          '<<< La colonna con l'indice
iNext = MenuSH.Cells(Rows.Count, 1).End(xlUp).Row + 1
With MenuSH
    .Cells(iNext, iCol).Value = mFile
    .Cells(iNext, iCol).Hyperlinks.Delete
    .Cells(iNext, iCol).Hyperlinks.Add Anchor:=.Cells(iNext, iCol), Address:=mFile
End With
End Sub

Le righe marcate <<< devono essere personalizzate

Poi torna sulla Sub Salvaprev e aggiungi questa "Call" in questa posizione:

Codice: Seleziona tutto

End If
Call myLink(myName)         'AGGIUNGERE in questa posizione
On Error GoTo 0

Ciao

[Zagor57]

Ciao Anthony
in riferimento a...

Se vuoi sapere cosa penso delle celle unite leggi qui: viewtopic.php?f=26&t=85065

non sono andato a vedere quello che pensi in quanto l'avevo già letto in un'altra tua risposta
detto questo il tutto sembri funzionare alla grande,una domanda nel copiare il foglio vorrei si copiasse solo il foglio attivo e non tutto il programma come??

ciao sei un grande come sempre

[Anthony47]

Caro zagor, quello che chiedi ora e' diverso da quello che avevi chiesto ieri:

quello che vorrei fare e il seguente
una volta compilato tutti i dati devo salvare il nuovo file con tutte le formule e quant'altro vi è nel file originale,con il nome della cella in ( G12 )

nel copiare il foglio vorrei si copiasse solo il foglio attivo e non tutto il programma come??

Le due cose richiedevano un approccio diverso, quindi ora ti propino un taccone che consiste nel cancellare dalla copia tutti i fogli meno quello attivo al momento di esecuzione della macro.

Aggiungi questa "ultima" macro:

Codice: Seleziona tutto

Sub stripSaved(ByVal mFile As String, ByVal Sh0 As String)
Application.EnableEvents = False
Workbooks.Open mFile
Application.DisplayAlerts = False
For I = ActiveWorkbook.Sheets.Count To 1 Step -1
    If Sheets(I).Name <> Sh0 Then
        Sheets(I).Delete
    End If
Next I
ActiveWorkbook.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub


Poi all'interno della Sub Salvaprev aggiungi questa Call in questa posizione:

Codice: Seleziona tutto

End If
Call stripSaved(myName, ActiveSheet.Name)        '<<< Da AGGIUNGERE
Call myLink(myName)
On Error GoTo 0


Ciao

[Zagor57]

Grazie Anthony Tutto perfetto
l'unica cosa e un po lento nel cancellare i dati il resto OK...............sei insostituibile

ciao