agc
-
21 déc. 2012 à 10:20
Patrice33740
Messages postés8556Date d'inscriptiondimanche 13 juin 2010StatutMembreDernière intervention 2 mars 2023
-
21 déc. 2012 à 14:54
Bonjour,
je viens sur le forum car je suis quasi novice en VBA et nécessite l'aide de pro du VBA;
j'utilise un macro qui a été écrite par un informaticien reconvertit dans la finance; cette macro a pour but de copier/coller dans un nouveau classeur certains onglets d'un fichier xls (2007) référencés dans les colonnes d'une feuille xls (onglet "paramètres") appartenant au même classeur et d'envoyer ce nouveau classeur composé des onglets précédemment copier via outlook à une liste de destinataires également référencés dans l'onglet "paramètre".
La macro s'arrete lorsqu'elle rencontre une cellule vide.
La macro d'origine était formatée pour 7 colonnes, j'ai ajouté 1 colonne et essayé d'adapter la macro pour 8 colonnes.
PB: la macro effectue parfaitement le premier envoi pouis s'arrête en positionnant la cellule active à la fin de la deuxième ligne (1ere cellule vide rencontrée de la deuxième ligne) mais pas d'envoi de la deuxième ligne.
je copie ci-dessous la macro d'origine (1) puis la macro adaptée (2):
Macro d'origine (1):
Sub ENVOI()
Dim NOM As String
Dim LAF1 As String
Dim LAF2 As String
Dim LAF3 As String
Dim LAF4 As String
Dim LAF5 As String
Dim LAF6 As String
Dim LAF7 As String
Dim LIBELLE As String
Dim PERSONNE As String
Dim SUJET As String
Dim MOIS As String
NOM = ActiveWorkbook.Name
'Pour que l'écran ne se modifie pas pendant l'exécution de la macro :
Application.ScreenUpdating = False
'Pour expliquer par message les erreurs pouvant avoir commises :
On Error GoTo TRAITERROR
'Message pour vérifier que le lancement de la macro est bien voulu :
Dim reponse As Integer
reponse = MsgBox("Avez-vous bien déplacer les onglets à envoyer à droite de l'onglet Paramètres ?", vbYesNo + vbQuestion)
If reponse = vbNo Then
MsgBox "Envoi par messagerie non effectué !"
Exit Sub
Else
MsgBox "Envoi par messagerie commencé. "
End If
'Message pour vérifier que la messagerie Outlook est ouverte :
Dim MESSAGERIE As Integer
MESSAGERIE = MsgBox("Est-ce que vous avez ouvert votre messagerie Outlook ?" & Chr _
(10) & "- Si OUI, choisir Oui" & Chr _
(10) & "- Si NON, choisir Non, car la macro ne pourra s'excécuter.", vbYesNo + vbQuestion)
If MESSAGERIE = vbNo Then
MsgBox "La macro s'est arrêtée. Ouvrez votre messagerie et relancez la macro."
Exit Sub
Else
End If
' virer les noms de champs pour gagner de la place
ActiveWorkbook.Names("Base_Planif").Delete
ActiveWorkbook.Names("Managers").Delete
ActiveWorkbook.Names("M").Delete
ActiveWorkbook.Names("N").Delete
ActiveWorkbook.Names("Services").Delete
ActiveWorkbook.SendMail Recipients:=PERSONNE, Subject:=SUJET, returnreceipt:=True
'MsgBox "Envoi par messagerie à " & PERSONNE
'RETOUR SUR LA FEUILLE DE LANCEMENT DES MACROS
Sheets("Macro").Activate
MsgBox "L'envoi par messagerie à vos correspondants est terminé."
TRAITERROR:
Select Case Err
Case 1004
Resume Next
Exit Sub
Case 9
Resume Next
Exit Sub
End Select
'Remise à jour du raffaichissement de l'écran :
Application.ScreenUpdating = True
End Sub
Macro adapdtée (2):
Sub ENVOI()
Dim NOM As String
Dim LAF1 As String
Dim LAF2 As String
Dim LAF3 As String
Dim LAF4 As String
Dim LAF5 As String
Dim LAF6 As String
Dim LAF7 As String
Dim LAF8 As String
Dim LIBELLE As String
Dim PERSONNE As String
Dim SUJET As String
Dim MOIS As String
NOM = ActiveWorkbook.Name
'Pour que l'écran ne se modifie pas pendant l'exécution de la macro :
Application.ScreenUpdating = False
'Pour expliquer par message les erreurs pouvant avoir commises :
On Error GoTo TRAITERROR
'Message pour vérifier que le lancement de la macro est bien voulu :
Dim reponse As Integer
reponse = MsgBox("Avez-vous bien déplacer les onglets à envoyer à droite de l'onglet Paramètres ?", vbYesNo + vbQuestion)
If reponse = vbNo Then
MsgBox "Envoi par messagerie non effectué !"
Exit Sub
Else
MsgBox "Envoi par messagerie commencé. "
End If
'Message pour vérifier que la messagerie Outlook est ouverte :
Dim MESSAGERIE As Integer
MESSAGERIE = MsgBox("Est-ce que vous avez ouvert votre messagerie Outlook ?" & Chr _
(10) & "- Si OUI, choisir Oui" & Chr _
(10) & "- Si NON, choisir Non, car la macro ne pourra s'excécuter.", vbYesNo + vbQuestion)
If MESSAGERIE = vbNo Then
MsgBox "La macro s'est arrêtée. Ouvrez votre messagerie et relancez la macro."
Exit Sub
Else
End If
' virer les noms de champs pour gagner de la place
ActiveWorkbook.Names("Base_Planif").Delete
ActiveWorkbook.Names("Managers").Delete
ActiveWorkbook.Names("M").Delete
ActiveWorkbook.Names("N").Delete
ActiveWorkbook.Names("Services").Delete
ActiveWorkbook.SendMail Recipients:=PERSONNE, Subject:=SUJET, returnreceipt:=True
'MsgBox "Envoi par messagerie à " & PERSONNE
Sub ENVOI()
Dim WBK As Workbook
Dim WSH As Worksheet
Dim CEL As Range
Dim PLAGENOMMEE As Name
Dim NOM As String
Dim LAF1 As String
Dim LAF2 As String
Dim LAF3 As String
Dim LAF4 As String
Dim LAF5 As String
Dim LAF6 As String
Dim LAF7 As String
Dim LAF8 As String
Dim LIBELLE As String
Dim PERSONNE As String
Dim SUJET As String
Dim MOIS As String
Dim REPONSE As Integer
NOM = ActiveWorkbook.Name
'Pour que l'écran ne se modifie pas pendant l'exécution de la macro :
Application.ScreenUpdating = False
'Pour expliquer par message les erreurs pouvant avoir commises :
On Error GoTo TRAITERROR
'Message pour vérifier que le lancement de la macro est bien voulu :
REPONSE = MsgBox("Avez-vous bien déplacé les onglets à envoyer à droite de l'onglet Paramètres ?", vbYesNo + vbQuestion)
If REPONSE = vbNo Then
MsgBox "Envoi par messagerie non effectué !"
Exit Sub
Else
MsgBox "Envoi par messagerie commencé. "
End If
'Message pour vérifier que la messagerie Outlook est ouverte :
REPONSE = MsgBox("Est-ce que vous avez ouvert votre messagerie Outlook ?" & Chr(10) & _
"- Si OUI, choisir Oui" & Chr(10) & _
"- Si NON, choisir Non, car la macro ne pourra s'excécuter.", vbYesNo + vbQuestion)
If REPONSE = vbNo Then
MsgBox "La macro s'est arrêtée. Ouvrez votre messagerie et relancez la macro."
Exit Sub
End If
MOIS = Sheets("Paramètres").Range("B26")
Set CEL = Sheets("Paramètres").Range("A16")
Do
With CEL
PERSONNE = .Value
LAF1 = .Offset(0, 1).Value
LAF2 = .Offset(0, 2).Value
LAF3 = .Offset(0, 3).Value
LAF4 = .Offset(0, 4).Value
LAF5 = .Offset(0, 5).Value
LAF6 = .Offset(0, 6).Value
LAF7 = .Offset(0, 7).Value
LAF8 = .Offset(0, 8).Value
LIBELLE = .Offset(0, 9).Value
End With
If PERSONNE = "Pas de destinataire" Then
MsgBox "Pas de destinataire pour la feuille " & LIBELLE
Else
'Copier les onglets ds nv classeur
Sheets(Array(LAF1, LAF2, LAF3, LAF4, LAF5, LAF6, LAF7, LAF8)).Select
Sheets(Array(LAF1, LAF2, LAF3, LAF4, LAF5, LAF6, LAF7, LAF8)).Copy
Set WBK = ActiveWorkbook
'Copier / collage spécial valeur de chaque page
For Each WSH In WBK.Worksheets
WSH.UsedRange.Value = WSH.UsedRange.Value
WSH.Activate
WSH.Range("A1").Activate
Next WSH
'Retour sur la première feuille envoyée
WBK.Sheets(1).Activate
SUJET = LIBELLE
WBK.SaveAs Filename:="C:\Import\" & LIBELLE
' virer les noms de champs pour gagner de la place
If WBK.Names.Count > 0 Then
For Each PLAGENOMMEE In WBK.Names
PLAGENOMMEE.Delete
Next PLAGENOMMEE
End If
WBK.SendMail Recipients:=PERSONNE, Subject:=SUJET, returnreceipt:=True
' MsgBox "Envoi par messagerie à " & PERSONNE
SendKeys "%N", False
WBK.Close (False)
End If
Set CEL = CEL.Offset(1)
Loop Until IsEmpty(CEL)
'RETOUR SUR LA FEUILLE DE LANCEMENT DES MACROS
Sheets("Macro").Activate
MsgBox "L'envoi par messagerie à vos correspondants est terminé."
'Remise à jour du raffaichissement de l'écran :
Application.ScreenUpdating = True
Exit Sub
TRAITERROR:
Select Case Err.Number
Case 1004
Resume Next
Case Else
MsgBox "Erreur n° " & Err.Number & vbCr & _
Err.Description & vbCr & vbCr & _
"Envoi interrompu."
Exit Sub
End Select
'Remise à jour du raffaichissement de l'écran :
Application.ScreenUpdating = True
End Sub
