Option Explicit
Sub MacroMail()
Dim AccuseReception As Boolean
Dim Sujet As String
Dim ShtSrc As Worksheet, ShtTmp As Worksheet
Dim Ctrl As Shape
' On memorise la feuille active pour plus tard
Set ShtSrc = ActiveSheet
[B][COLOR=Red]Application.Calculation = xlCalculationManual[/COLOR][/B]
' on copie la feuille source (donc la feuille active) dans une nouvelle feuille en fin de fichier
ShtSrc.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
' on memorise la feuille temporaire (plus facile pour la manipuler ensuite)
Set ShtTmp = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
' on copie/colle valeurs la plage qui nous interesse dans la feuille temporaire
With ShtTmp.Range("A1:AA5000")
.Copy
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
[COLOR=Red][B]Application.Calculation = xlCalculationAutomatic[/B][/COLOR]
AccuseReception = True
Sujet = "Demande de communication de boîte archives auprès ADLA"
'Copie de la feuille temporaire dans un nouveau classeur
ShtTmp.Copy
'Eventuellement on renomme la feuille pour eviter le (2) en fin de nom d'onglet
ActiveSheet.Name = ShtSrc.Name
'Suppresion des boutons de la feuille temporaire
For Each Ctrl In ActiveSheet.Shapes
If Ctrl.FormControlType = xlButtonControl Then
Ctrl.Delete
End If
Next Ctrl
' envoi du mail et fermeture du classeur nouvellement cree (sans l'enregistrer)
ActiveWorkbook.SendMail "", Sujet, AccuseReception
ActiveWorkbook.Close False
'suppression de la feuille temporaire (on desactive, au passage, les messages d'alerte pour ne pas a avoir a confirmer la suppression)
Application.DisplayAlerts = False
ShtTmp.Delete
Application.DisplayAlerts = True
'on reactive la feuille source
ShtSrc.Activate
'on fait un peu de menage dans la memoire
Set ShtTmp = Nothing
Set ShtSrc = Nothing
End SubOption Explicit
Sub MacroMail()
Dim AccuseReception As Boolean
Dim Sujet As String
Dim WrkDst As Workbook
Dim ShtOrigine As Worksheet, ShtSrc As Worksheet, ShtTmp As Worksheet
Dim Ctrl As Shape
'pour eviter l'effet stroboscopique on fige l'affichage
Application.ScreenUpdating = False
'Memorisation de la feuille d'origine
Set ShtOrigine = ActiveSheet
'On boucle sur toutes les feuilles du classeur
For Each ShtSrc In ThisWorkbook.Sheets
'Si le nom de la feuille contient "bilan-"
If Left(LCase(ShtSrc.Name), 6) = "bilan-" Then
Application.Calculation = xlCalculationManual
' on copie la feuille source dans une nouvelle feuille en fin de fichier
ShtSrc.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
' on memorise la feuille temporaire (plus facile pour la manipuler ensuite)
Set ShtTmp = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
' on copie/colle valeurs la plage qui nous interesse dans la feuille temporaire
With ShtTmp.Range("A1:AA5000")
.Copy
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.Calculation = xlCalculationAutomatic
' si le classeur des destination n'est pas cree
If WrkDst Is Nothing Then
'Copie de la feuille temporaire dans un nouveau classeur
ShtTmp.Copy
' memorisation du classeur destination
Set WrkDst = Workbooks(ActiveSheet.Parent.Name)
Else
'sinon
'Copie de la feuille temporaire dans le classeur destination
ShtTmp.Copy after:=WrkDst.Sheets(WrkDst.Sheets.Count)
End If
'Eventuellement on renomme la feuille pour eviter le (2) en fin de nom d'onglet
ActiveSheet.Name = ShtSrc.Name
'Suppresion des boutons de la feuille temporaire
For Each Ctrl In ActiveSheet.Shapes
If Ctrl.FormControlType = xlButtonControl Then
Ctrl.Delete
End If
Next Ctrl
'suppression de la feuille temporaire (on desactive, au passage, les messages d'alerte pour ne pas a avoir a confirmer la suppression)
Application.DisplayAlerts = False
ShtTmp.Delete
Application.DisplayAlerts = True
End If
Next ShtSrc
AccuseReception = True
Sujet = "Demande de communication de boîte archives auprès ADLA"
' envoi du mail et fermeture du classeur destination (sans l'enregistrer)
WrkDst.SendMail "", Sujet, AccuseReception
WrkDst.Close False
'on reactive la feuille d'origine
ShtOrigine.Activate
'on fait un peu de menage dans la memoire
Set ShtOrigine = Nothing
Set ShtTmp = Nothing
Set ShtSrc = Nothing
Set WrkDst = Nothing
'on retablie l'affichage
Application.ScreenUpdating = True
End Sub
, din l'nord)
