Option Explicit
Sub annuaire()
Dim shImp As Worksheet, shAnn As Worksheet
Dim i&, j As Byte, lstRow&
Set shImp = ThisWorkbook.Sheets("IMPORT")
Set shAnn = ThisWorkbook.Sheets("ANNUAIRE")
With shImp
For i = 1 To .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If Not .Cells(i, "A").Value = "" Then
lstRow = shAnn.[a65000].End(xlUp).Row + 1
shAnn.Cells(lstRow, "A").Value = .Cells(i + 1, "A").Value
shAnn.Cells(lstRow, "B").Value = .Cells(i + 3, "A").Value
shAnn.Cells(lstRow, "C").Value = .Cells(i + 4, "A").Value
.Cells(i, "A").Copy shAnn.Cells(lstRow, "D")
.Cells(i + 1, "B").Copy shAnn.Cells(lstRow, "E")
.Cells(i + 2, "B").Copy shAnn.Cells(lstRow, "F")
shAnn.Cells(lstRow, "G").Value = .Cells(i + 3, "B").Value
shAnn.Cells(lstRow, "H").Value = .Cells(i + 4, "B").Value
shAnn.Cells(lstRow, "I").Value = .Cells(i + 5, "B").Value
'Cherche la fin du bloc.
Do Until .Rows(i).Find("*") Is Nothing
i = i + 1
Loop
End If
Next i
End With
End Sub