Bonjour le forum,
Je travaille depuis quelques temps (par intermittence) sur une macro qui permet :
- d'extraire des données d'une feuille Excel et de les copier dans un autre classeur ;
- d'envoyer par mail une copie de la feuille en en ôtant les macros et en la verrouillant pour que l'utilisateur final ne puisse plus intervenir que sur quelques cellules (la date à laquelle il a corrigé l'anomalie et son nom).
Or, je sèche un peu.
Dans mon esprit, on part d'un classeur "Test.xlsm" que le premier utilisateur remplit. Puis, la macro extrait les données et réalise une copie du fichier en l'enregistrant avec comme nom le nom de la cellule E1.
C'est ce document qui est conservé par le premier utilisateur. Mais, avant de l'envoyer à l'utilisateur final, il faut supprimer les boutons des macros, les numéros, les consignes, désactiver les macros et verrouiller la quasi-totalité de la feuille.
Or, cela ne fonctionne pas.
Par ailleurs, l'extraction se fait très bien, mais en colonne (c'est-à-dire sur les cellules A1, A2, A3, A4 ...), au lieu de le faire par ligne : de A1 à A9, puis de B1 à B9, puis de C1 à C9.
Je joins mon (très long) code et mon fichier test, en espérant que quelqu'un puisse m'aiguiller vers la solution.
Merci d'avance.
Cordialement.
Je travaille depuis quelques temps (par intermittence) sur une macro qui permet :
- d'extraire des données d'une feuille Excel et de les copier dans un autre classeur ;
- d'envoyer par mail une copie de la feuille en en ôtant les macros et en la verrouillant pour que l'utilisateur final ne puisse plus intervenir que sur quelques cellules (la date à laquelle il a corrigé l'anomalie et son nom).
Or, je sèche un peu.
Dans mon esprit, on part d'un classeur "Test.xlsm" que le premier utilisateur remplit. Puis, la macro extrait les données et réalise une copie du fichier en l'enregistrant avec comme nom le nom de la cellule E1.
C'est ce document qui est conservé par le premier utilisateur. Mais, avant de l'envoyer à l'utilisateur final, il faut supprimer les boutons des macros, les numéros, les consignes, désactiver les macros et verrouiller la quasi-totalité de la feuille.
Or, cela ne fonctionne pas.
Par ailleurs, l'extraction se fait très bien, mais en colonne (c'est-à-dire sur les cellules A1, A2, A3, A4 ...), au lieu de le faire par ligne : de A1 à A9, puis de B1 à B9, puis de C1 à C9.
Je joins mon (très long) code et mon fichier test, en espérant que quelqu'un puisse m'aiguiller vers la solution.
Merci d'avance.
Cordialement.
Code:
Sub NumerAuto()
Dim fso As Object, chemin As String, f As Object, i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
i = 1
'Cells(i, 1) = "Sous dossiers"
'Cells(i, 2) = "Nb fichiers"
For Each f In fso.GetFolder(chemin).SubFolders
i = i + 1
'Cells(i, 1) = f.Name
Cells(i, 6) = f.Files.Count
'x = x + f.Files.Count
Next f
End Sub
Sub Enreg()
Dim chemin As String, Chemin2 As String, Repertoire As String, Fichier As String, Fichier2 As String, Fichier4 As String, Rep As String
Dim pl As Range
Dim i As Long
Dim cel As Range
chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
Chemin2 = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\"
Repertoire = Range("A9").Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").Range("E1").Value & ".xlsx"
Fichier4 = "Extraction.xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled
With Sheets("Feuil2")
'définit la plage pl des données que l’on veut importer
Set pl = Application.Union(.Cells(8, 5), .Cells(9, 1), .Cells(9, 2), .Cells(9, 5), .Cells(13, 2), .Cells(15, 2), .Cells(15, 5), .Cells(17, 2), .Cells(17, 5))
End With
Workbooks.Open Chemin2 & Fichier4
Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
'Workbooks(Chemin2 & Fichier4).Activate
With ActiveWorkbook.Sheets("Feuil1")
i = .UsedRange.Rows.Count 'compte le nombre de lignes déjà utilisées dans ce fichier
décalageColonne = 0
For Each cel In pl
cel.Copy .Cells(i + 1, 1 + décalageColonne)
décalageColonne = décalageColonne + 1
Next cel
End With
ActiveWorkbook.Close SaveChanges:=True
Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
Workbooks.Open Filename:=chemin & Fichier
Workbooks(Fichier2).Close SaveChanges:=False
End If
End Sub
Sub EnregImprim()
Dim chemin, Repertoire, Fichier, Fichier2, Rep As String
chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
Repertoire = [A9].Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").[E1].Value & ".xlsx"
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveSheet.PrintOut
Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
Workbooks.Open Filename:=chemin & Fichier
Workbooks(Fichier2).Close SaveChanges:=False
End If
End Sub
Sub Imprim()
ActiveSheet.PrintOut
End Sub
Sub EnregMail()
Dim chemin, Repertoire, Fichier, Fichier2, Rep, destinataire1, destinataire2, destinataire3, destinataire4, destinataire5, cc, body, sujet, strcommand, fichierjoint As String
destinataire1 = "b.pratiot@zouzou.fr"
destinataire2 = "p.mokal@zouzou.fr"
destinataire3 = "x.boggie@zouzou.fr"
destinataire4 = "p.prazuline@zouzou.fr"
destinataire5 = "c.barchot@zouzou.fr"
cc = "controle@zouzou.fr"
chemin = "G:\XXXX\YYYY\ZZZZ\2013\AAAA\BBBB\"
Repertoire = [A9].Value & "\"
Fichier = "Test.xlsm"
Fichier2 = Sheets("Feuil2").[E1].Value & ".xlsm"
Fichier3 = Sheets("Feuil2").[E1].Value & ".xlsm"
fichierjoint = chemin & Repertoire & Fichier3
ActiveWorkbook.SaveAs Filename:=chemin & Repertoire & Fichier2, FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveSheet.Copy
ActiveSheet.SaveAs Filename:=chemin3 & Fichier2, FileFormat:=xlNormal
ActiveSheet.Select
ActiveSheet.Buttons.Add(18, 57.75, 83.25, 36.75).Select
ActiveSheet.Buttons.Add(117.75, 57, 83.25, 36.75).Select
ActiveSheet.Buttons.Add(217.5, 57.75, 83.25, 36.75).Select
ActiveSheet.Buttons.Add(317.25, 57, 83.25, 36.75).Select
ActiveSheet.Buttons.Add(415.5, 56.25, 83.25, 36.75).Select
Sheets("Feuil2").Copy
ActiveSheet.Shapes.Range(Array("Button 1", "Button 2", "Button 3", "Button 4" _
, "Button 5", "Oval 10", "Oval5", "Rectangle1", "Oval8", "Rectangle 3", "Oval 7", "Rectangle 9", "Rectangle 15", "Rectangle 16", "Rectangle 17", "Rectangle 18", "Rectangle 4", "Oval 6")). _
Select
Selection.Delete
ActiveWindow.SmallScroll Down:=-6
Range("A1:E45").Select
ActiveWindow.SmallScroll Down:=21
Range("E46").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
If [A9].Value = "A" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire1 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "B" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire2 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "C" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire3 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "D" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire3 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "E" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire4 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "F" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire5 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "G" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire5 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
If [A9].Value = "H" Then
sujet = "Fiche anomalie"
body = "<HTML><BODY>Bonjour" & "," & "<br>" & "<br>" & "Nous vous prions de trouver ci-joint" & ", " & _
"une fiche anomalie concernant la saisie d'un technicien de votre service." & _
" Nous vous remercions de lui transmettre ladite fiche et de lui demander de régulariser le dossier dans les meilleurs délais." & _
"<br>" & "<br>" & "<br>" & "Bien cordialement." & "<br>" & "<br>" & "<br>" & "<br>" & "Le Service Contrôle.</BODY></HTML>"
strcommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strcommand = strcommand & " -compose " & "to='" & destinataire6 & "'"
strcommand = strcommand & "," & "cc='" & cc & "'"
strcommand = strcommand & "," & "subject='" & sujet & "',format='1',"
strcommand = strcommand & "body='" & body & "'"
strcommand = strcommand & "," & "attachment='file:///" & fichierjoint & "'"
Call Shell(strcommand, vbNormalFocus)
End If
Rep = MsgBox("Voulez-vous revenir au modèle et fermer la présente fiche anomalie ?", vbYesNo + vbQuestion, "Le programme demande votre attention")
If Rep = vbYes Then
Workbooks.Open Filename:=chemin & Fichier
Workbooks(Fichier2).Close SaveChanges:=False
End If
End Sub