Effacer cellules vides copie feuille nouveau classeur

Le 24/06/2017 à 17:26

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

Le 24/06/2017 à 18:46

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
Le 24/06/2017 à 19:14

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

Rechercher des sujets similaires à "effacer vides copie feuille nouveau classeur"