Pb suite modification macro: ça fonctionne mal

agc -  
Patrice33740 Messages postés 8400 Date d'inscription   Statut Membre Dernière intervention   -
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

Sheets("Paramètres").Activate
Range("A16").Activate
PERSONNE = ActiveCell.Value

Range("B16").Activate
LAF1 = ActiveCell.Value
Range("C16").Activate
LAF2 = ActiveCell.Value
Range("D16").Activate
LAF3 = ActiveCell.Value
Range("E16").Activate
LAF4 = ActiveCell.Value
Range("F16").Activate
LAF5 = ActiveCell.Value
Range("G16").Activate
LAF6 = ActiveCell.Value
Range("H16").Activate
LAF7 = ActiveCell.Value
Range("I16").Activate
LIBELLE = ActiveCell.Value

MOIS = Sheets("Paramètres").Range("B26")

Do
If PERSONNE = "Pas de destinataire" Then
MsgBox "Pas de destinataire pour la feuille " & LIBELLE

Else
'Copier les 2 onglets ds nv classeur
Sheets(Array(LAF1, LAF2, LAF3, LAF4, LAF5, LAF6, LAF7)).Select
Sheets(Array(LAF1, LAF2, LAF3, LAF4, LAF5, LAF6, LAF7)).Copy

'Copier / collage spéciale valeur Page 1
Sheets(LAF1).Activate
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 2
Sheets(LAF2).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 3
Sheets(LAF3).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 4
Sheets(LAF4).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 5
Sheets(LAF5).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 6
Sheets(LAF6).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 7
Sheets(LAF7).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Retour sur la première feuille envoyée
Sheets(LAF1).Select
Range("A1").Select

SUJET = LIBELLE

ActiveWorkbook.SaveAs Filename:= _
"C:\Import\" & LIBELLE, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

' 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

SendKeys "%N", False
ActiveWorkbook.Close (False)

End If

Sheets("Paramètres").Activate
ActiveCell.Offset(1, -8).Activate
PERSONNE = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF2 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF3 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF4 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF5 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF6 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF7 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LIBELLE = ActiveCell.Value

Loop Until IsEmpty(ActiveCell)

'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

Sheets("Paramètres").Activate
Range("A16").Activate
PERSONNE = ActiveCell.Value

Range("B16").Activate
LAF1 = ActiveCell.Value
Range("C16").Activate
LAF2 = ActiveCell.Value
Range("D16").Activate
LAF3 = ActiveCell.Value
Range("E16").Activate
LAF4 = ActiveCell.Value
Range("F16").Activate
LAF5 = ActiveCell.Value
Range("G16").Activate
LAF6 = ActiveCell.Value
Range("H16").Activate
LAF7 = ActiveCell.Value
Range("I16").Activate
LAF8 = ActiveCell.Value
Range("J16").Activate
LIBELLE = ActiveCell.Value

MOIS = Sheets("Paramètres").Range("B26")

Do
If PERSONNE = "Pas de destinataire" Then
MsgBox "Pas de destinataire pour la feuille " & LIBELLE

Else
'Copier les 2 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

'Copier / collage spéciale valeur Page 1
Sheets(LAF1).Activate
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 2
Sheets(LAF2).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 3
Sheets(LAF3).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 4
Sheets(LAF4).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 5
Sheets(LAF5).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 6
Sheets(LAF6).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 7
Sheets(LAF7).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Copier / collage spéciale valeur Page 8
Sheets(LAF8).Select
Range("A1:DK3000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select

'Retour sur la première feuille envoyée
Sheets(LAF1).Select
Range("A1").Select

SUJET = LIBELLE

ActiveWorkbook.SaveAs Filename:= _
"C:\Import\" & LIBELLE, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

' 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

SendKeys "%N", False
ActiveWorkbook.Close (False)

End If

Sheets("Paramètres").Activate
ActiveCell.Offset(1, -8).Activate
PERSONNE = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF2 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF3 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF4 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF5 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF6 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF7 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LAF8 = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
LIBELLE = ActiveCell.Value

Loop Until IsEmpty(ActiveCell)

'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

Merci de votre aide !

1 réponse

  1.
    Patrice33740 Messages postés 8400 Date d'inscription   Statut Membre Dernière intervention   1 784
     
    Bonjour,

    Essaies ce code : 
    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


    Cordialement
    Patrice
    0

Discussions similaires

Modifier une annonce ou le prix sur Leboncoin sans payer
BourrinOman83 -
Clarckos -

22 réponses
Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses
remplacement avec sed
CYG -
jipicy -

8 réponses
modifier simultanément un fichier partagé
DJ2020 -
DJ2020 -

20 réponses