Effacer cellules vides copie feuille nouveau classeur
Bonjour a tous,
je reviens vers vous car j'ai un soucis.
J'ai un classeur avec la feuille FTE qui a des cellules non verouillées a remplir.
Cette feuille est ensuite copié dans un nouveau classeur via macro.
Je voudrai que la feuille FTE du classeur initial se vide une fois la copie faite.
J'ai un bou de macro mais je n'y arrive pas, soit ça me vide le classeur initial et me fait la copie par la suite soit ça me copie la feuille FTE et me vide le nouveau classeur.
Si vous pouvez m'aider je vous mets ma macro en dessous et en rouge le passage qui m'interresse.
Merci a vous de votre aide.
Sub EnvoiMail10()
Dim ret As Integer
ret = MsgBox("Voulez-vous valider?", vbYesNo, "Demande de confirmation")
If ret = vbYes Then
End If
If ret = vbNo Then
Exit Sub
End If
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Bonjour,<br><br>" & _
"Nouvelle demande de purge et conditionnement de circuit." & _
"<br><br>Cliquez sur ce lien pour ouvrir le fichier concerné : " & _
"<A HREF=""file://\\liens" & _
""">ici</A>" & _
"<br><br>Cordialement," & _
"<br><br>L'Équipe ML Labo</font>"
On Error Resume Next
With OutMail
.To = "email"
.CC = ""
.BCC = ""
.Subject = "Demande de purge et conditionnement de circuit"
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Dim chemin As String
Nom = [K2]
Sheets("FTE").Copy
chemin = "C:\Users\f18170\Desktop\ML labo - EX\FTE\"
With ActiveWorkbook
.Worksheets(1).Shapes("Bouton 16").Delete
.SaveAs Filename:=chemin & "FTE n°" & Nom, FileFormat:=52
End With
For Each cel In Sheets("FTE").UsedRange
If Not cel.Locked Then cel.Value = ""
Next cel
Dim sh As Worksheet
For Each sh In Worksheets
sh.EnableAutoFilter = True
sh.EnableOutlining = True
sh.Protect Contents:=True, Password:="", UserInterfaceOnly:=True
Next
Dim NewM As Object, NewCode As String
For i = 12 To 19
With ThisWorkbook.VBProject.VBComponents("Module" & i).CodeModule
NewCode = .Lines(1, .CountOfLines)
End With
Set NewM = ActiveWorkbook.VBProject.VBComponents.Add(1)
With ActiveWorkbook.VBProject.VBComponents(NewM.Name).CodeModule
.DeleteLines 1, .CountOfLines
.AddFromString NewCode
End With
Next i
End Sub
- Messages
- 4'094
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonjour,
apporter cette modification :
Dim wb_initial As Workbook, chemin As String
Set wb_initial = ActiveWorkbook
Nom = [K2]
Sheets("FTE").Copy
chemin = "C:\Users\f18170\Desktop\ML labo - EX\FTE\"
With ActiveWorkbook
.Worksheets(1).Shapes("Bouton 16").Delete
.SaveAs Filename:=chemin & "FTE n°" & Nom, FileFormat:=52
End With
For Each cel In wb_initial.Sheets("FTE").UsedRange
If Not cel.Locked Then cel.ClearContents
Next cel
Super merci beaucoup ca fonctionne.
J'ai juste modifié un peu la macro car plus besoins de supprimer le bouton 16 qui permettait de vider les cellules non protégées et j'ai modifié la dernière ligne car autrement ceci me mettait une erreur.
Merci encore de ton aide
Pour info voici la macro
Dim wb_initial As Workbook, chemin As String
Set wb_initial = ActiveWorkbook
Nom = [K2]
Sheets("FTE").Copy
chemin = "C:\Users\f18170\Desktop\ML labo - EX\FTE\"
With ActiveWorkbook
.SaveAs Filename:=chemin & "FTE n°" & Nom, FileFormat:=52
End With
For Each cel In wb_initial.Sheets("FTE").UsedRange
If Not cel.Locked Then cel.Value = ""
Next cel