Problèmes de macro liés à l'extraction et à l'envoi d'un fichier

benadry

XLDnaute Occasionnel
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.

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
 

Pièces jointes

  • Test.xlsm
    51.6 KB · Affichages: 33
  • Test.xlsm
    51.6 KB · Affichages: 47
  • Test.xlsm
    51.6 KB · Affichages: 44

Discussions similaires