Login
Registrati
Stai vedendo 12 articoli - dal 1 a 12 (di 12 totali)
-
Articoli
-
Ciao a tutti,
Ho un file che tramite macro mi salva una copia in xlsm con la copia integrale di tutto il codice vba dell'originale. Mi chiedo è possibile escludere in questa copia alcune macro? ad esempio il file originale alla sua apertura prevede un reset completo del foglio + un Array che copia e salva le formule per poi essere ripristinate all'evenienza. Ecco io vorrei che il file originale facesse tutto questo, ma il file copiato non abbia questa funzione (perchè nel file copiato ci devono essere alcune informazioni salvate) in quanto appena apro il file copiato chiaramente mi resetta tutto anche le informazioni che io ho salvato appositamente.
Grazie a tutti per l'aiuto
Lascio codice all'apertura foglio che è quello che dovrebbe essere escluso:
`Private Sub Workbook_Open() Dim ii As Byte Dim jj As Byte Dim tt As Byte Dim xx As Variant Dim uu As Variant Dim ss As Variant 'con x dichiaro un array (cioè un insieme di elementi) che in questo caso sono _ i riferimenti alle celle che contengono le formule e che saranno interessate _ all'inserimento di dati tramite le textbox xx = Array("B7", "b13", "B14", "B15", "B16", "B17", "B18", "B19", "B22", "B23", "B24", "B25", "B26", "B27", "D22", "D23", "D24", "D25", _ "D26", "D27", "D28", "D29", "D30", "D31", "D32", "D33", "D34", "D35", "D36", "D37", "D38", "D39", "D40", "D41", "D42", "D43", _ "D44", "D45", "D46", "D47", "D48", "D49", "D50", "D51", "D52", "D53", "D54", "D55", "A59", "A60", "A61", "A62", "C60", "C61", "D43", _ "C62", "D59", "D60", "D61", "D62", "D63", "D65", "D66", "D67", "D68", "a71", "m2", "j3") uu = Array("D5", "D6", "D7", "D8", "D9", "D10", "D11", "D12", "D13", "D14", "D15", "D16", "D17", "D18", "D19", "D20", "D21", "D22", "D23", "D24", "B5", _ "B6", "B7", "B8", "B9", "B10", "B11", "C12", "C13", "C14", "C15", "B16", "C17", "C18", "C19", "C20", "C21", "C22", "A23", "A24", "C23", "C24", _ "A39", "D39", "A40", "D40", "A41", "D41", "A42", "D42", "A43", "D43", "A44", "A45", "A46", "A47", "A48", "A49", "A50", "A51", "A52", "A53", "A54", _ "A55", "A56", "D44", "D45", "D46", "D47", "D48", "D49", "D50", "D51", "D52", "D53", "D54", "D55", "D56", "A25", "C25", "D25", "A26", "C26", "D26", _ "A27", "C27", "D27", "A28", "C28", "D28", "A29", "D29", "A30", "D30", "A31", "D31", "A32", "D32", "A33", "D33", "A34", "D34", "A35", "D35", "A36", "D36", _ "A37", "D37", "A38", "D38") ss = Array("A37", "A38", "A39", "A40", "D5", "D6", "D7", "D8", "D9", "D10", "D11", "D12", "D13", "D14", "D15", "C12", "C13", "C14", "C15", _ "D16", "C17", "C18", "C19", "C20", "C21", "C22", "D17", "D18", "D19", "D20", "D21", "D22", _ "C23", "C24", "C25", "C26", "C27", "C28", "D23", "D24", "D25", "D26", "D27", "D28", "D29", "D30", "D31", "D32", "D33", "D34", "D35", _ "D36", "D37", "D38", "D39", "D40", "B5", "B6", "B7", "B8", "B9", "B10", "B11", "B12", "B13", "B14", "B15", "B17", "B16", "B18", _ "B19", "B20", "B21", "B22", "A23", "A24", "A25", "A26", "A27", "A28", "A29", "A30", "A31", "A32", "A33", "A34", "A35", "A36", _ "A41", "A42", "A43", "A44", "A45", "A46", "A47", "A48", "A49", "A50", "A51", "A52", "A53", "A54", "A55", "A56", "A57", "A58", "A59", "A60", "A61", "A62", "A63", "A64", _ "B66", "B67", "C67", "C63", "C62", "C61", "C60", "C59", "C58", "C57", "C56", "C55", "C54", "C53", "C52", "C51", "C50", "C48", "C49", "C47", "C46", "C45", "C44", "A69", "C69", _ "A65", "A66", "D41", "D42", "D43", "D44", "D45", "D46", "D47", "D48", "D49", "D50", "D51", "D52", "D53", "D54", "D55", "D56", "D57", "D58", "D59", _ "D60", "D61", "D62", "D63", "D64", "D65", "D66", "D67", "D68", "A68", "B65") With ThisWorkbook For ii = 1 To 68 Formule_in_Celle4(ii) = .Worksheets("Input Backup").Range(xx(ii - 1)).FormulaLocal NumberFormat_in_Celle4(ii) = .Worksheets("Input Backup").Range(xx(ii - 1)).NumberFormat Next ii For jj = 1 To 110 Formule_in_Celle5(jj) = .Worksheets("Output Backup").Range(uu(jj - 1)).FormulaLocal NumberFormat_in_Celle5(jj) = .Worksheets("Output Backup").Range(uu(jj - 1)).NumberFormat Next jj For tt = 1 To 169 Formule_in_Celle6(tt) = .Worksheets("Output Weekend Backup").Range(ss(tt - 1)).FormulaLocal NumberFormat_in_Celle6(tt) = .Worksheets("Output Weekend Backup").Range(ss(tt - 1)).NumberFormat Next tt End With Call BackupFoglio Call BackupFoglioOutput Call BackupFoglioOutputWeekend Call ResetFoglio End Sub</code></pre><p>ed il codice che lancia le varie copie a cui gli si dovrebbe dire, quando salvi il file xlsm escludi queste 4 macro:</p><p>Call BackupFoglio<br />Call BackupFoglioOutput<br />Call BackupFoglioOutputWeekend<br />Call ResetFoglio</p><p>Codice:</p><pre class="language-c"><code>Option Explicit Sub save_as() Dim p As String Dim s As String Dim V As Variant Dim i As Integer, uRiga As Integer Dim wb1 As Workbook Dim wb2 As Workbook 'inizio istruzioni cursore mouse With Application .ScreenUpdating = False .Cursor = xlWait End With Set wb1 = ThisWorkbook 'in wb1 imposto riferimento a questo foglio di lavoro Set wb2 = Workbooks.Add 'in wb2 imposto riferimento a nuovo foglio di lavoro p = "Z:\Altri computer\Il mio computer\Archivio\UFFICO BOOKING\PROVA FILE UNICO" 'inserire percorso cartelle preventivi ' p = "C:\Users\alebo\Downloads\Lavori in Excel\Preventivi" 'variabile per salvataggio con nome s = "@A - @B - @C - @D" For i = 1 To 4 V = Choose(i, "B3", "B1", "B6", "B7") s = Replace(s, "@" & Chr$(64 + i), wb1.Worksheets("Input").Range(V)) Next ' inserire il nome della cartella preventivi excel al posto di Preventivi Excel wb1.Worksheets.Copy before:=wb2.Worksheets(1) 'in cella N46 del foglio originale salvo data e ora di creazione del foglio copiato wb2.Worksheets("Input").Range("N46") = "Preventivo creato il " & Date wb2.SaveAs p & "\EXCEL\" & Replace(s, "/", "-") & ".xlsx", FileFormat:=xlWorkbookDefault For Each V In wb2.LinkSources(Type:=xlLinkTypeExcelLinks) wb2.BreakLink Name:=V, Type:=xlLinkTypeExcelLinks Next wb1.SaveCopyAs p & "\VBA\" & Replace(s, "/", "-") & ".xlsm" wb1.Worksheets("Input").Range("N45").Value = p & "\PDF\" & Replace(s, "/", "-") & ".pdf" With Worksheets("Input") If .Range("E7") > 3 Then With wb2.Worksheets("Output") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio End If 'fine istruzioni cursore mouse With Application .ScreenUpdating = True .Cursor = xlDefault End With With Worksheets("Input") If .Range("E7") < 3 Then With wb2.Worksheets("Output Weekend") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio Call BackupFoglio Call BackupFoglioOutput Call BackupFoglioOutputWeekend Call ResetFoglio End If With Application .ScreenUpdating = True .Cursor = xlDefault End With Set wb1 = Nothing: Set wb2 = Nothing End With End With End Sub `Questo codice serve per eliminare una macro da un modulo.
Crediti:
Dal sito:http://www.mvps.org/dmcritchie/excel/xlindex.htm
articolo:VBE, Programming to The Visual Basic Editor, Chip Pearson, code to add/delete modules, [to manually delete from within the VBE, File, Remove Module]
Sub DeleteProcedure() Dim VBCodeMod As CodeModule Dim StartLine As Long Dim HowManyLines As Long Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("NomeModulo").CodeModule With VBCodeMod StartLine = .ProcStartLine("NomeMacro", vbext_pk_Proc) HowManyLines = .ProcCountLines("NomeMacro", vbext_pk_Proc) .DeleteLines StartLine, HowManyLines End With End SubProvato e funziona.
Sinceramente ho forti difficoltà a farlo entrare nel codice ho provato cosi ma non va, tenendo conto che deve eliminare il workbook_open presente nella cartella di lavoro non in un modulo e lo deve fare solo per il nuovo file xlsm e non per il file originale da cui parte la macro
Option Explicit Sub save_as() Dim p As String Dim s As String Dim V As Variant Dim i As Integer, uRiga As Integer Dim wb1 As Workbook Dim wb2 As Workbook Dim wb3 As Workbook Dim VBCodeMod As CodeModule Dim StartLine As Long Dim HowManyLines As Long 'inizio istruzioni cursore mouse With Application .ScreenUpdating = False .Cursor = xlWait End With Set wb1 = ThisWorkbook 'in wb1 imposto riferimento a questo foglio di lavoro Set wb2 = Workbooks.Add Set wb3 = Workbooks.Add 'in wb3 imposto riferimento a nuovo foglio di lavoro p = "Z:\Altri computer\Il mio computer\Archivio\UFFICO BOOKING\PROVA FILE UNICO" 'inserire percorso cartelle preventivi ' p = "C:\Users\alebo\Downloads\Lavori in Excel\Preventivi" 'variabile per salvataggio con nome s = "@A - @B - @C - @D" For i = 1 To 4 V = Choose(i, "B3", "B1", "B6", "B7") s = Replace(s, "@" & Chr$(64 + i), wb1.Worksheets("Input").Range(V)) Next ' inserire il nome della cartella preventivi excel al posto di Preventivi Excel wb1.Worksheets.Copy before:=wb2.Worksheets(1) 'in cella N46 del foglio originale salvo data e ora di creazione del foglio copiato wb2.Worksheets("Input").Range("N46") = "Preventivo creato il " & Date wb2.SaveAs p & "\EXCEL\" & Replace(s, "/", "-") & ".xlsx", FileFormat:=xlWorkbookDefault For Each V In wb2.LinkSources(Type:=xlLinkTypeExcelLinks) wb2.BreakLink Name:=V, Type:=xlLinkTypeExcelLinks Next wb1.Worksheets.Copy before:=wb3.Worksheets(1) With wb3 Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule With VBCodeMod StartLine = .ProcStartLine("Woorkbook_Open", vbext_pk_Proc) HowManyLines = .ProcCountLines("Woorkbook_Open", vbext_pk_Proc) .DeleteLines StartLine, HowManyLines End With End With wb3.SaveCopyAs p & "\VBA\" & Replace(s, "/", "-") & ".xlsm" wb3.Close True wb1.Worksheets("Input").Range("N45").Value = p & "\PDF\" & Replace(s, "/", "-") & ".pdf" With Worksheets("Input") If .Range("E7") > 3 Then With wb2.Worksheets("Output") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio End If 'fine istruzioni cursore mouse With Application .ScreenUpdating = True .Cursor = xlDefault End With With Worksheets("Input") If .Range("E7") < 3 Then With wb2.Worksheets("Output Weekend") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio Call BackupFoglio Call BackupFoglioOutput Call BackupFoglioOutputWeekend Call ResetFoglio End If With Application .ScreenUpdating = True .Cursor = xlDefault End With Set wb1 = Nothing: Set wb2 = Nothing End With End With End Suballego un file se si volesse provare
Niente non riesco a richiamare quel codice nel codice stampa
Option Explicit Sub save_as() Dim p As String Dim s As String Dim V As Variant Dim i As Integer, uRiga As Integer Dim wb1 As Workbook Dim wb2 As Workbook 'inizio istruzioni cursore mouse With Application .ScreenUpdating = False .Cursor = xlWait End With Set wb1 = ThisWorkbook 'in wb1 imposto riferimento a questo foglio di lavoro Set wb2 = Workbooks.Add p = "Z:\Altri computer\Il mio computer\Archivio\UFFICO BOOKING\PROVA FILE UNICO" 'inserire percorso cartelle preventivi ' p = "C:\Users\alebo\Downloads\Lavori in Excel\Preventivi" 'variabile per salvataggio con nome s = "@A - @B - @C - @D" For i = 1 To 4 V = Choose(i, "B3", "B1", "B6", "B7") s = Replace(s, "@" & Chr$(64 + i), wb1.Worksheets("Input").Range(V)) Next ' inserire il nome della cartella preventivi excel al posto di Preventivi Excel wb1.Worksheets.Copy before:=wb2.Worksheets(1) 'in cella N46 del foglio originale salvo data e ora di creazione del foglio copiato wb2.Worksheets("Input").Range("N46") = "Preventivo creato il " & Date wb2.SaveAs p & "\EXCEL\" & Replace(s, "/", "-") & ".xlsx", FileFormat:=xlWorkbookDefault For Each V In wb2.LinkSources(Type:=xlLinkTypeExcelLinks) wb2.BreakLink Name:=V, Type:=xlLinkTypeExcelLinks Next wb1.SaveCopyAs p & "\VBA\" & Replace(s, "/", "-") & ".xlsm" Call DeleteProcedure Call DeleteAllVBA wb1.Worksheets("Input").Range("N45").Value = p & "\PDF\" & Replace(s, "/", "-") & ".pdf" With Worksheets("Input") If .Range("E7") > 3 Then With wb2.Worksheets("Output") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio End If 'fine istruzioni cursore mouse With Application .ScreenUpdating = True .Cursor = xlDefault End With With Worksheets("Input") If .Range("E7") < 3 Then With wb2.Worksheets("Output Weekend") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio Call BackupFoglio Call BackupFoglioOutput Call BackupFoglioOutputWeekend Call ResetFoglio End If With Application .ScreenUpdating = True .Cursor = xlDefault End With Set wb1 = Nothing: Set wb2 = Nothing End With End With End Subin pratica vorrei che quando crea il file xlsm cancelli il modulo 13 dove sono presenti le macro di reset e cancelli tutto il workbook nel nuovo file lasciando chiaramente tutto nel file originale. Ho provato cosi ma mi da errore. Allego file
Grazie dell'aiuto
Premetto che la soluzione proposta da Aldo non la conoscevo ma credo che sia valida...però un'alternativa potrebbe essere quella di far scrivere in una cella non utilizzabile del Foglio Copiato una parola chiave ("Vero", "Si", "Confermo", ecc...) e nell'evento Open del Workbook si fa un check su questa cella che se NON riporta quel testo (o valore) allora esegue tutte le istruzioni di reset, viceversa se contiene quel testo allora non esegue le istruzioni di reset.
Prova a vedere se riesci. Dovresti far in modo che al salvataggio della Copia, il codice va a scrivere in una cella inutilizzata, una parola a tuo piacimento, poi, una volta effettuato il salvataggio della Copia, prima di chiudere il file originale (quindi su evento BeforeClose), deve andare a cancellare il contenuto di questa cella (altrimenti quella parola te la ritrovi anche anche nel file originale).
Ciao Alex,
La soluzione di Aldo sicuramente valida purtroppo non riuscivo a metterla in pratica. La tua ha centrato il segno!!!
Option Explicit Sub save_as() Dim p As String Dim s As String Dim V As Variant Dim i As Integer, uRiga As Integer Dim wb1 As Workbook Dim wb2 As Workbook 'inizio istruzioni cursore mouse With Application .ScreenUpdating = False .Cursor = xlWait End With Set wb1 = ThisWorkbook 'in wb1 imposto riferimento a questo foglio di lavoro Set wb2 = Workbooks.Add 'in wb2 imposto riferimento a nuovo foglio di lavoro p = "Z:\Altri computer\Il mio computer\Archivio\UFFICO BOOKING\PROVA FILE UNICO" 'inserire percorso cartelle preventivi ' p = "C:\Users\alebo\Downloads\Lavori in Excel\Preventivi" 'variabile per salvataggio con nome s = "@A - @B - @C - @D" For i = 1 To 4 V = Choose(i, "B3", "B1", "B6", "B7") s = Replace(s, "@" & Chr$(64 + i), wb1.Worksheets("Input").Range(V)) Next ' inserire il nome della cartella preventivi excel al posto di Preventivi Excel wb1.Worksheets.Copy before:=wb2.Worksheets(1) 'in cella N46 del foglio originale salvo data e ora di creazione del foglio copiato wb2.Worksheets("Input").Range("N46") = "Preventivo creato il " & Date wb2.SaveAs p & "\EXCEL\" & Replace(s, "/", "-") & ".xlsx", FileFormat:=xlWorkbookDefault For Each V In wb2.LinkSources(Type:=xlLinkTypeExcelLinks) wb2.BreakLink Name:=V, Type:=xlLinkTypeExcelLinks Next wb1.Worksheets("Input").Range("N70") = "No" wb1.SaveCopyAs p & "\VBA\" & Replace(s, "/", "-") & ".xlsm" wb1.Worksheets("Input").Range("N45").Value = p & "\PDF\" & Replace(s, "/", "-") & ".pdf" With Worksheets("Input") If .Range("E7") > 3 Then With wb2.Worksheets("Output") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" .Range("N70") = "" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio End If 'fine istruzioni cursore mouse With Application .ScreenUpdating = True .Cursor = xlDefault End With With Worksheets("Input") If .Range("E7") < 3 Then With wb2.Worksheets("Output Weekend") ' inserire il nome della cartella preventivi PDF al posto di Preventivi Excel .Select uRiga = .Cells(Rows.Count, "B").End(xlUp).Row .Range("$A$5:$D$65").AutoFilter Field:=4, Criteria1:="<>" With .PageSetup .PrintArea = "A1:D" & uRiga .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With .ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=p & "\PDF\" & Replace(s, "/", "-") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End With wb2.Worksheets("Input").Select wb2.Close True 'salva e chiude il nuovo foglio creato With wb1.Worksheets("Input") ' inizio istruzioni di resettaggio celle .Range("B1,B2,B4,B5,B12:D12,B6:D6,E7,B8:D12,B20:D20,j2,J4:J6,J9,J11,M3,N45,D56,D57,D58,M7:M9,D64").ClearContents .Range("B6:D6") = "8/11/2024" .Range("E7") = "7" .Range("B8:D8") = "2" .Range("B9:D9") = "1" .Range("A56:C56") = "Rigo personalizzabile" .Range("A57:C57") = "Rigo personalizzabile" .Range("A58:C58") = "Rigo personalizzabile" .Range("N70") = "" ' istruzione di aggiunta +1 al preventivo .Range("B3").Value = .Range("B3").Value + 1 End With With UserForm1 'qui ovviamente ci vuole il nome dell'userform reale .CheckBox1 = False .CheckBox2 = False .TextBox1.Value = "" Call UserForm1.btnConferma_Click End With Call RipristinaFoglio Call BackupFoglio Call BackupFoglioOutput Call BackupFoglioOutputWeekend Call ResetFoglio End If With Application .ScreenUpdating = True .Cursor = xlDefault End With Set wb1 = Nothing: Set wb2 = Nothing End With End With End SubChiaramente nel workbook ho inserito un If sulla cella N70. Funziona tutto egregiamente. Grazie mille
Questo codice serve per eliminare una macro da un modulo.
Per completezza vi ricordo che tra i riferimenti dovete abilitare la voce "Microsoft Visual Basic for Applications Extensibility 5.3", per accedere agli oggetti dei componenti VBE.
la soluzione proposta da Aldo non la conoscevo ma credo che sia valida
E' valida sì e la farei rientrare tra le tecniche avanzate, poco usate ma utili da conoscere... se sei interessato, chiedi e ti apriamo un mondo
ciao,
sicuramente in questo periodo la mia testa (quale
) è altrove....ma ho un dubbio e solo per sapere:
l'Aticolo 5 del Regolamento del Forum è tutt'ora in vigore?
l'Aticolo 5 del Regolamento del Forum è tutt'ora in vigore?
Domanda retorica naturalmente, e la risposta e' ovviamente si'. Poi possiamo discutere su quanto deve essere lungo il codice per essere sopportabile...
"Postare codice senza esagerare" lo ritieni applicabile a questa discussione? Diciamo che il post di Frost sarebbe effettivamente lungo da leggere (anche perche' avulso da un contesto normale) ma lui ha postato una soluzione, non un codice da spulciare. L'alternativa sarebbe chiedere di allegare un file, ma io non trovo cosi' fuori luogo la condivisione del codice (che ripeto serve solo a lui... e' troppo calato in un contesto specifico
)Buonasera,
Premettendo che ogni regola va rispettata, dal mio punto di vista posso solo aggiungere che spesso mi sono trovato davanti (non qui) a codici parziali e con spiegazioni da valutare. Per me che non sono un veterano del VBA spesso mi ha aiutato trovare dei codici completi e funzionanti che mi hanno dato la possibilità (non sapendo scrivere un linguaggio da capo a piedi) di valutarne le parti e riadattarle alle mie esigenze. Detto questo effettivamente io posto quasi sempre cose abbastanza soggettive e mi scuso se posso sembrare lungo e troppo esaustivo. Ma ci tengo anche a precisare, che dato che spesso o sempre mi viene data una mano, è giusto condividere la soluzione corretta con gli altri e con chi ti ha aiutato.
Domanda retorica naturalmente, e la risposta e' ovviamente si'. Poi possiamo discutere su quanto deve essere lungo il codice per essere sopportabile...
chiaro...
grazie
se dovesse capitarmi di pormi delle domande... mi darò le risposte da solo...
o forse meglio... non mi porrò domande...
ricordate "Qualcuno volò sul nido del cuculo"?
grazie
(anche perche' avulso da un contesto normale) ma lui ha postato una soluzione, non un codice da spulciare.
per capirlo... non avrei dovuto "spulciarlo"?
Stai vedendo 12 articoli - dal 1 a 12 (di 12 totali)