1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
|
Sub CopieDuClasseurOriginalSansMacro(P_FichierCible)
Dim chemin As String, nom As String, sh As Worksheet, i As Long
Dim VBComp As VBComponent, VBComps
'*****************************************************************************
'on ajoute la référence si elle n'y est pas (Microsoft visual basic for application extensibility x.y
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
err.Clear
'******************************************************************************
chemin = ThisWorkbook.Path & "\" ' on précise le chemin
nom = P_FichierCible '"classeur sans macro.xls" ' on précise le nom du classeur de destination
'on créé un tableau des sheets
ReDim tablo(Sheets.Count)
For Each sh In Worksheets
tablo(i) = sh.Name
i = i + 1
Next
Sheets(tablo).Copy ' on copie les feuilles
'on vire tout les module et code du nouveau classeur
With ActiveWorkbook.VBProject
For Each VBComp In .VBComponents 'on boucle sur tout les modules
Select Case VBComp.Type ' ons electionne le type
Case 100 'si c'est une feuille
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines 'on efface les lignes de code
End With
Case Else
VBComps.Remove VBComp 'si c'est une autre sorte de module (standard ou classe) on le vire
End Select
Next
End With
Application.DisplayAlerts = False 'on supprime les fenetres d'avertissement
'et voila maintenant on sauve le nouveau classeur
' ActiveWorkbook.SaveAs Filename:=chemin & nom, FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.SaveCopyAs Filename:=P_FichierCible, FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
' ActiveWindow.Close 'on ferme le nouveau classeur pour revenir au classeur de base
'si tu n'a pas besoin de garder le classeur de base ouvert apres avoir enregistré le nouveau classeur
'tu peut faire
'Application.quit
End Sub |
Partager