Copia foglio su altro file senza esportare tasti e immagini

[BG66]

Buongiorno,
oggi giornata di finalizzazione di files.
con la macro nuovofile ottengo il risultato. Ma nel nuovo file mi trascino anche bottoni e icone presenti nel master.
Come posso evitarlo ?
Per capire, ho provato utilizzando il registratore ma il risultato non c'è stato.

Codice: Seleziona tutto

Sub nuovofile()
'dichiaro le variabili
    Dim wk1 As Workbook
    'Dim wk2 As Workbook
    Dim sh1 As Worksheet
    'Dim sh2 As Worksheet

'gestione errori
On Error GoTo RigaErrore

    'metto i riferimenti ai files
    Set wk1 = ThisWorkbook
    'Set wk2 = Workbooks("infortunio___.xlsx")
    'metto i riferimenti ai fogli
    Set sh1 = wk1.Worksheets("Sheet1")
    'Set sh2 = wk2.Worksheets("Sheet1")

    With sh1
        'copio i dati da un file all'altro
    'Range("A1:AA69").Select
    'Range("AA69").Activate
    Sheets("Incident Investigation").Select
    Sheets("Incident Investigation").Copy
    ChDir "C:\Users\Microsoft\Desktop\Appoggio"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Microsoft\Desktop\Appoggio\macro da fare\infortunio___.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End With

    'ActiveSheet.Shapes.Range(Array("Immagine 6")).Select
    'Selection.Delete
    'ActiveSheet.Shapes.Range(Array("Immagine 2")).Select
    'Selection.Delete
    'ActiveSheet.Shapes.Range(Array("Immagine 4")).Select
    'Range("AD36").Select
    'ActiveSheet.Shapes.Range(Array("btnDateReported")).Select
    'Selection.Delete
    'Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("btnDateReported")).Select
    'Selection.Delete
    'Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("btnIncDes")).Select
    'Selection.Delete
   ' Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("btnDateIncident")).Select
   ' Selection.Delete
   ' Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("btnLocation")).Select
   ' Selection.Delete
   ' Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("btnConditions")).Select
   ' Selection.Delete
  '  Selection.Cut
   ' ActiveWindow.SmallScroll Down:=3
  '  ActiveSheet.Shapes.Range(Array("btnEquipment")).Select
   ' Selection.Delete
   ' Selection.Cut
    'ActiveSheet.Shapes.Range(Array("btnInjBody")).Select
   ' Selection.Delete
   ' Selection.Cut
   ' ActiveWindow.SmallScroll Down:=6
    'ActiveSheet.Shapes.Range(Array("btnInjNature")).Select
   ' Selection.Delete
   ' Selection.Cut
   ' ActiveWindow.SmallScroll Down:=30
  ' ActiveSheet.Shapes.Range(Array("btnImmeChse")).Select
   ' Selection.Delete
  '  Selection.Cut
 '   ActiveWindow.SmallScroll Down:=18
 '   Range("D70:AA110").Select
  '  Range("AA110").Activate
  '  ActiveSheet.Shapes.Range(Array("btnPrintSave")).Select
  '  Selection.Delete
   ' Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("btnPrintSave")).Select
    'Selection.Delete
   ' Selection.Cut
  '  ActiveSheet.Shapes.Range(Array("btnEmailForm")).Select
  '  Selection.Delete
   ' Selection.Cut
  '  ActiveSheet.Shapes.Range(Array("btnEmailForm")).Select
  '  Selection.Delete
   ' Selection.Cut
  '  ActiveSheet.Shapes.Range(Array("btnEmailForm")).Select
  '  Selection.Delete
  '  Selection.Cut
   ' Range("F117").Select
  '  ActiveSheet.Shapes.Range(Array("Immagine 5")).Select
  '  Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("Immagine 7")).Select
  '  Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("Immagine 4")).Select
   ' Selection.Cut
   ' ActiveSheet.Shapes.Range(Array("Immagine 2")).Select
   ' Selection.Cut
  '  ActiveSheet.Shapes.Range(Array("Immagine 6")).Select
   ' Selection.Cut
    'ActiveWorkbook.Save
    'ActiveWindow.Close
   
    'riga sempre eseguita
RigaChiusura:
    'Set a Nothing delle variabili oggetto
    Set sh2 = Nothing
    Set sh1 = Nothing
    Set wk1 = Nothing
    Set wk2 = Nothing
    Exit Sub

'in caso di errore
RigaErrore:
    MsgBox Err.Number & vbNewLine & Err.Description
    Resume RigaChiusura
End Sub


Grazie per l'aiuto.....bis...
https://www.dropbox.com/s/a4kdm9qu8su2c2e/Incident-Investigation%20vForum.xlsm?dl=0

[Anthony47]

Se vuoi ripulire il foglio dalle sue Shapes allora dovrebbe bastare inserire questo ciclo dopo la Copy di partenza:

Codice: Seleziona tutto

    Sheets("Incident Investigation").Copy                   'La "Copia" del foglio
    'Ciclo per la puizia:                                   'AGGIUNGERE QUESTO CICLO         
    For Each mySh In ActiveSheet.Shapes
        mySh.Delete
    Next mySh
    'continua la tua macro


Ciao

[BG66]

Ciao Anthony,
il ciclo è un pò troppo "talebano" ossia cancella anche delle caselle di controllo ( es. casella di controllo 14092,cdc 14093) che mi sono necessarie.
C'è la possibilità di inserire delle esclusioni nel ciclo?
Al momento lo script è diventato cosi:

Codice: Seleziona tutto

Sub nuovofileAnthony()
'dichiaro le variabili
    Dim wk1 As Workbook
    'Dim wk2 As Workbook
    Dim sh1 As Worksheet
    'Dim sh2 As Worksheet

'gestione errori
On Error GoTo RigaErrore

    'metto i riferimenti ai files
    Set wk1 = ThisWorkbook
    'Set wk2 = Workbooks("infortunio___.xlsx")
    'metto i riferimenti ai fogli
    Set sh1 = wk1.Worksheets("Sheet1")
    'Set sh2 = wk2.Worksheets("Sheet1")

    With sh1
        'copio i dati da un file all'altro
    'Range("A1:AA69").Select
    'Range("AA69").Activate
    Sheets("Incident Investigation").Select
    Sheets("Incident Investigation").Copy                   'La "Copia" del foglio
    'Ciclo per la puizia:                                   'AGGIUNGERE QUESTO CICLO         
    For Each mySh In ActiveSheet.Shapes
        mySh.Delete
    Next mySh
    'ActiveSheet.Shapes.Range(Array("Immagine 6")).Select
    'Selection.Delete
    'ActiveSheet.Shapes.Range(Array("Immagine 2")).Select
    'Selection.Delete
    'ActiveSheet.Shapes.Range(Array("Immagine 4")).Select
    'Range("AD36").Select
    'continua la tua macro
    ChDir "C:\Users\Microsoft\Desktop\Appoggio"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\Microsoft\Desktop\Appoggio\macro da fare\infortunio___.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    End With
 
    'ActiveWorkbook.Save
    'ActiveWindow.Close
   

    'riga sempre eseguita
RigaChiusura:
    'Set a Nothing delle variabili oggetto
    Set sh2 = Nothing
    Set sh1 = Nothing
    Set wk1 = Nothing
    Set wk2 = Nothing
    Exit Sub

'in caso di errore
RigaErrore:
    MsgBox Err.Number & vbNewLine & Err.Description
    Resume RigaChiusura
End Sub

Grazie

[Anthony47]

Qui le cose si fanno per bene o non si fanno...

Se vuoi escludere qualche shape dall'eliminazione puoi usare la loro posizione (.TopLeftCell.Address), o il loro nome (.Name)
Esempio:

Codice: Seleziona tutto

    For Each mySh In ActiveSheet.Shapes
        If UCase(Left(mySh.Name, 5)) <> "CHECK" Then mySh.Delete
    Next mySh

Questo risparmia dalla cancellazione i checkbox inseriti sia come Modulo che come Activex.
Ovviamente devi stare attento, se rinomini le forme, a chiamarle sempre "Check*******"

Ciao

[BG66]

Ciao Anthony,
ho rinominato:
n° 2 caselle di controllo e n° 1 immagine usando il prefisso Check
poi lancia la macro filenuovoAnthony ma il file creato non le mantiene.

https://www.dropbox.com/s/5ywtqjhdnfyewa3/Incident-Investigation%20vAnthony1.xlsm?dl=0

Grazie per l'aiuto e la pazienza...

[Anthony47]

Gene, se scrivi

Codice: Seleziona tutto

If UCase(Left(mySh.Name, 5)) <> "Check" Then mySh.Delete

allora il risultato sara' sempre Vero e quindi si procedera' sempre con mySh.Delete

INFATTI io avevo scritto:

Codice: Seleziona tutto

If UCase(Left(mySh.Name, 5)) <> "CHECK" Then mySh.Delete

Ciao!

[BG66]

Ciao Anthony,
avevo fatto anche la prova con CHECK maiuscolo ma il risultato non era cambiato.
https://www.dropbox.com/s/mnnexpn8973nkqy/Incident-Investigation%20vAnthony1%2B.xlsm?dl=0
Forse sbaglio qualcosa nel nominare le caselle?

[Anthony47]

Se parto dal tuo file ed eseguo la Sub nuovofileAnthony, nel nuovo file trovo che sono rimasti presenti

Codice: Seleziona tutto

Posizione       Nome
 $F$62        Check14092
 $F$63        Check 14093
 $E$59        Check IMG 1


Tutte le altre sono state eliminate:

Codice: Seleziona tutto

$B$4          AutoShapeGen1 >>>>>>>>>>>>>>>>>> DEL
$B$38         AutoShapeImm >>>>>>>>>>>>>>>>>> DEL
$H$47         btnImmeChse >>>>>>>>>>>>>>>>>> DEL
$I$26         btnInjBody >>>>>>>>>>>>>>>>>> DEL
$G$28         btnInjNature >>>>>>>>>>>>>>>>>> DEL
$I$5          btnDateIncident >>>>>>>>>>>>>>>>>> DEL
$V$8          btnDateReported >>>>>>>>>>>>>>>>>> DEL
$F$15         btnLocation >>>>>>>>>>>>>>>>>> DEL
$G$18         btnConditions >>>>>>>>>>>>>>>>>> DEL
$F$23         btnEquipment >>>>>>>>>>>>>>>>>> DEL
$K$11         btnIncDes >>>>>>>>>>>>>>>>>> DEL
$R$69         btnEmailForm >>>>>>>>>>>>>>>>>> DEL
$D$69         btnPrintSave >>>>>>>>>>>>>>>>>> DEL
$L$69         Button 12 >>>>>>>>>>>>>>>>>> DEL
$H$69         Button 13 >>>>>>>>>>>>>>>>>> DEL
$V$69         Button 14 >>>>>>>>>>>>>>>>>> DEL
$B$32         AutoShapeImm >>>>>>>>>>>>>>>>>> DEL
$AD$11        Immagine 2 >>>>>>>>>>>>>>>>>> DEL
$AD$9         Immagine 4 >>>>>>>>>>>>>>>>>> DEL
$AD$3         Immagine 5 >>>>>>>>>>>>>>>>>> DEL
$AD$13        Immagine 6 >>>>>>>>>>>>>>>>>> DEL
$AD$6         Immagine 7 >>>>>>>>>>>>>>>>>> DEL
$AD$1         Picture 26 >>>>>>>>>>>>>>>>>> DEL


Che mi pare sia quello che volevi ottenere. Tu arrivi a risultati diversi?

[BG66]

Il risultato che ottengo è (ad esempio per la riga 59 -> sparisce Check IMG 1, mentre tu lo vedi presente) :


Stesso risultato per le caselle di controllo presenti nelle righe 62 e 63 (-> spariscono Check14092 e Check 14093)


Il dopo è il file che segue:
https://www.dropbox.com/s/fnv5qobuglge1te/infortunio___.xlsx?dl=0

Mi dispiace farti impazzire ma proprio non riesco a capire..

[Anthony47]

La cosa mi incuriosisce, piu' che farmi impazzire…

Facciamo così: lavorando sul file completo, modifica il ciclo di pulizia all'interno della Sub nuovofileAnthony come segue:

Codice: Seleziona tutto

    'Ciclo per la puizia:                                   'CICLO MODIFICATO
    For Each mysh In ActiveSheet.Shapes
       If UCase(Left(mysh.Name, 5)) <> "CHECK" Then
            Debug.Print ">>> Deleted: ", mysh.TopLeftCell.Address, mysh.Name
            mysh.Delete
        Else
            Debug.Print mysh.TopLeftCell.Address, mysh.Name
        End If
    Next mysh


Esegui poi la Sub nuovofileAnthony (eseguila tramite Alt-F8); a conclusione apri la finestra Immediata del vba (tasti Contr-g), copia quello che c'e' dentro e allegalo al tuo prossimo messaggio.


A me dice:

Codice: Seleziona tutto

. . . .
>>> Deleted:  $AD$13        Immagine 6
>>> Deleted:  $AD$6         Immagine 7
$F$62         Check14092
$F$63         Check 14093
$E$59         Check IMG 1
>>> Deleted:  $AD$1         Picture 26


Il file ottenuto e' coerente con questo report.
Stesso esito su XL2010 e XL2016

Ciao

[BG66]

Ciao Anthony,
premesso che è la prima volta che uso la finestra immediata e quindi potrei aver sbagliato..comunque il risultato ottenuto è il seguente:

[Anthony47]

Se la "finestra Immediata" risulta vuota dopo che la Sub nuovofileAnthony e' stata modificata come da suggerimento di ieri sera, allora la logica mi direbbe che la Sub nuovofileAnthony non e' stata eseguita...

Prova usarndo il file con cui io faccio le prove:
https://www.dropbox.com/s/vkezqujzufrbd ... .xlsm?dl=0

Se anche con questo file l'esito e' incomprensibile, nello stesso file ho inserito una Sub nuovofileAnthony2, che usa questo diverso ciclo di cancellazione:

Codice: Seleziona tutto

    'Ciclo per la pulizia:                                   'CICLO MODIFICATO
    For i = ActiveSheet.Shapes.Count To 1 Step -1
       If UCase(Left(ActiveSheet.Shapes(i).Name, 5)) <> "CHECK" Then
            Debug.Print ">>> Deleted: ", ActiveSheet.Shapes(i).TopLeftCell.Address, ActiveSheet.Shapes(i).Name
            ActiveSheet.Shapes(i).Delete
        Else
            Debug.Print ActiveSheet.Shapes(i).TopLeftCell.Address, ActiveSheet.Shapes(i).Name
        End If
    Next i


Prova anche con questo...

[BG66]

Ciao Anthony,
scusami per la latitanza ma mali di stagione mi hanno temporaneamente messo KO.
Spero di riuscire a fare qualche prova nel WE.

A presto
Gene

[BG66]

Ciao Anthony,
il tuo file funzionava perfettamente ma non riuscivo a riprodurre il risultato nel file master.
Mentre con Sub nuovofileAnthony2 ...[RISOLTO].

Grazie mille.
Gene