Sub Transfert()
Dim lig As Long, a As Range, cel As Range, col As Byte
lig = 2
With Feuil2 'CodeName
.[2:65536].ClearContents
For Each a In Feuil1.[A:A].SpecialCells(xlCellTypeConstants).Areas
.Cells(lig, 1) = Application.Trim(a.Cells(1)) 'SUPPRESPACE
Repere "Adresse", a, .Cells(lig, 2)
Repere "T?l?phone", a, .Cells(lig, 5), True
Repere "Fax", a, .Cells(lig, 6), True
Repere "Internet", a, .Cells(lig, 7)
Repere "Courriel", a, .Cells(lig, 8)
Repere "Pr?sident", a, .Cells(lig, 9)
Repere "DN", a, .Cells(lig, 10)
For Each cel In a 'code postal et ville
If cel Like "#####*" Then
.Cells(lig, 3) = Left(cel, 5)
.Cells(lig, 4) = Application.Trim(Mid(cel, 6, 99))
Exit For
End If
Next
lig = lig + 1
Next
For col = 1 To 10 'ajustement largeur colonnes
.Columns(col).AutoFit
Next
.Activate
End With
End Sub
Sub Repere(txt$, a As Range, cel As Range, Optional epure As Boolean)
Dim ref As Range
Set ref = a.Find(txt, LookIn:=xlValues, LookAt:=xlPart)
If ref Is Nothing Then Exit Sub
txt = Application.Trim(Mid(ref, Len(txt) + 3, 99)) 'SUPPRESPACE
If epure Then txt = Replace(txt, " ", "")
cel = txt
End Sub