Bonjour

j'ai un fichier excel de N onglets que je dois diffuser à certaines personnes selon leurs responsabilités (donc fichier à diffuser en entier ou par morceaux).
Ma macro balaye la matrice de diffusion et vérifie quels onglets envoyer
- si tous les onglets : envoie du fichier actif directement
- si quelques onglets, la macro liste ces onglets, les copie/colle dans une nouveau fichier qu'elle renomme et envoie ce fichier par mail

Actuellement la macro "tourne" quand je ne remplis qu'1 seule ligne de la matrice et envoie correctement le fichier entier/découpé pour cette personne.
En revanche quand je crée une 2e ligne avec une 2e personne, seul le 1er fichier est créé/envoyé. Impossible d'avoir le fichier de la 2e personne.
Je pense que c'est un problème de boucle mais lorsque je fonctionne en mode debug je vois que le 2e fichier se crée mais je ne comprends pas pq le mail ne se prépare pas...

Pouvez vous m'aider ?

Ci joint le code (pr simplifier j'ai mis le même destinataire en dur dans le code)
Merci d'avance

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Sub DiffusionLivrables()
 
'on définit les variables
Dim appOutlook As Outlook.Application
Dim OutApp As Object
Dim OutMail As Object
Dim NbLigne As Integer
Dim NbCol As Integer
Dim i As Integer
Dim j As Integer
Dim NombreOnglet As Integer
Dim PlanOp As Range
Dim PlanOpCol As Integer
Dim TableauContactRole As Range
Dim NumContrat As Integer
Dim Nomfeuille As String
Dim NomContrat As String
Dim Resp As String
Dim NomActeur As String
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
'Penser a activer la librairie Outlook
'On définit les données pour la Matrice de diffusion
 
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
 
 
Chemin = ThisWorkbook.Path
NomFichierArbitrage = ThisWorkbook.Name
 
 
Sheets("Matrice").Select
NbLigne = Sheets("Matrice").Range("A1").End(xlDown).Row
NbCol = Sheets("Matrice").Range("A1").End(xlToRight).Column
 
For i = 2 To NbLigne
    Sheets("Matrice").Select
    NombreOnglet = Application.WorksheetFunction.CountA(Sheets("Matrice").Rows(i))
     If NombreOnglet > 1 Then
 
Resp = Cells(i,1)
 
    ' on prépare les élements du mail
             Textbody = "Bonjour," & vbCrLf & vbCrLf & "" & _
                            "Contrat Banco N°XX " & vbCrLf & "" & _
                            "vous trouverez ci-joint le fichier d'arbitrage concernant l'execution du contrat" & vbCrLf & vbCrLf & "" & _
                            "Merci d'en prendre connaissance et de réaliser les actions vous concernant" & vbCrLf & vbCrLf & "" & _
                            "Cordialement"
 
 
        If NombreOnglet = NbCol - 1 Then
                On Error Resume Next
                With OutMail
                    .To = "test@mail.com"
                    .CC = ""
                    .BCC = ""
                    .Subject = ThisWorkbook.Name
                    .Attachments.Add Chemin & "\" & NomFichierArbitrage
                    .Body = Textbody
                    '.HTMLBody = Textbody
                    .Display 'visu @Mail
                    .Send       ' pour l'envoi du @mail
                End With
                On Error GoTo 0
            Else
                MsgBox ("Etes vous sur de vouloir envoyer le Plan des opération?")
            End If
        'on n'envoie pas tous le fichiers donc il faut tester onglet par onglet et créer un nouveau fichier avec chaque onglet
        Else
 
                NomFichier = "XX" & "Fichier Arbitrage_" & Resp & "_" & Replace(CStr(Date), "/", "")
                Sheets("Matrice").Select
 
                For j = 2 To NbCol
                        If Cells(i, j) <> "" Then
                        Ongletj = Cells(1, j)
                        Nomfeuille = Nomfeuille & "," & Ongletj
 
                    End If
 
                Next j
 
                Call exportexcel(Nomfeuille, NomFichier)
                 On Error Resume Next
                 NomFichierEnvoi = Chemin & "\" & NomFichier & ".xlsx"
 
 
                With OutMail
                    .To = "test@mail.com"
                    .CC = ""
                    .BCC = ""
                    .Subject = NomFichier
                    .Attachments.Add NomFichierEnvoi
                    .Body = Textbody
                    '.HTMLBody = Textbody
                    '.Display 'visu @Mail
                    .Send       ' pour l'envoi du @mail
                End With
                On Error GoTo 0
 
 
Nomfeuille = ""
        End If
 
Next i
 
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
 
End Sub
 
 
Sub exportexcel(nom_feuille As String, Nom)
 
Dim ListeOnglet() As String
 
NomOnglet = Mid(nom_feuille, 2)
Dossier = ThisWorkbook.Path
ListeOnglet = Split(NomOnglet, ",")
 
 
ThisWorkbook.Sheets(ListeOnglet).Select
ThisWorkbook.Sheets(ListeOnglet).Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Dossier & "\" & Nom & ".xlsx"
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
 
 
End Sub