Sub Trier()
Dim Wk As Workbook
Dim Ws As Worksheet
Dim i As Integer
Dim maplage As Range, Cel As Range
Dim Chemin As String
Dim NbLng As Integer
'Chemin d'accès du fichier
Chemin = "C:\Documents and Settings\david-v\Bureau\Fichiers excel annexes\Toto.xlsm"
'Feuille de référence
Set Ws = ActiveWorkbook.Sheets("Liste Mails")
'Plage de référence que l'on veut copier
Set maplage = Ws.Range("A1:A" & Ws.Range("A65536").End(xlUp).Row)
Workbooks.Open (Chemin)
Set Wk = ActiveWorkbook
For Each Cel In maplage
If Cel.Value <> "" And Cel.Column = maplage.Column Then
For i = 1 To Wk.Sheets.Count
If Cel.Value Like "*" & Wk.Sheets(i).Name & "*" Then
With Sheets(i)
If .Range("B65536").End(xlUp).Row = 1 Then
NbLng = .Range("B65536").End(xlUp).Row + 1
Else
NbLng = .Range("B65536").End(xlUp).Row + 1
End If
.Range(.Cells(NbLng, 2), .Cells(NbLng, 2 + maplage.Columns.Count - 1)).Value = Ws.Range(Ws.Cells(Cel.Row, maplage.Column), Ws.Cells(Cel.Row, maplage.Column + maplage.Columns.Count - 1)).Value
End With
End If
Next i
End If
Next Cel
End Sub