Private Sub CommandButton1_Click()
Dim Cell As Range, Plage As Range
Dim Cible As New Collection
Dim I As Integer
Dim Wb As Workbook
'Dim Ol As New Outlook.Application
'Dim olMail As MailItem
Application.ScreenUpdating = False
On Error Resume Next
'creation liste de clients
For Each Cell In ThisWorkbook.Sheets("tri").Range("A2:A" & _
ThisWorkbook.Sheets("tri").Range("A65536").End(xlUp).Row)
Cible.Add Cell, CStr(Cell)
Next Cell
On Error GoTo 0
'filtre par client et sur les affaires impayées ( colonne G non cochée )
For I = 1 To Cible.Count
ThisWorkbook.Sheets("tri").Range("A1").AutoFilter field:=1, Criteria1:=Cible(I)
'ThisWorkbook.Sheets("Feuil1").Range("A1").AutoFilter field:=7, Criteria1:=""
Set Wb = Workbooks.Add
Set Plage = ThisWorkbook.Sheets("tri").Cells.SpecialCells(xlVisible)
Plage.Copy Wb.Sheets("feuil1").Range("A1")
Wb.SaveAs "D:\" & Cible(I) & ".xls"
Wb.Close
'--------- creation d'un message Outlook contenant le classeur créé----------
Set Ol = New Outlook.Application
Set olMail = Ol.CreateItem(olMailItem)
With olMail
.To = Cible(I)
.Subject = "Tableau souscriptions pour " & Cible(I)
.Body = "Bonjour , " & vbLf & "Voici la liste " & _
vbLf & "Cordialement" & vbLf & "V"
.Attachments.Add "d:\" & Cible(I) & ".xls"
'.DeferredDeliveryTime = Date + 2 + #5:00:00 AM#
.OriginatorDeliveryReportRequested = False 'confirmation de réception
.ReadReceiptRequested = False 'confirmation de lecture
.Display
'.Send 'envoi
End With
'------ option pour supprimer les fichiers apres l'envoi---------------------
'Kill "C:\" & Cible(i) & " " & Format(Date, "yyyy mm dd") & ".xls"
'----------------------------------------------------------------------------
ThisWorkbook.Sheets("tri").ShowAllData
Set Wb = Nothing
Next I
Application.ScreenUpdating = True
End Sub