Sub RecupBase()
Dim Plage As Range
Dim Cel1 As Range
Dim Cel2 As Range
Dim Tbl(1 To 7) As String
Dim I As Long
Dim J As Integer
Dim K As Integer
Dim L As Long
Dim Adr As String
With Worksheets("Source")
'en colonne B
Set Plage = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
End With
Set Cel2 = Plage.Find(1, Plage(1), xlValues, xlWhole)
If Not Cel2 Is Nothing Then
'mémorise la première et son adresse
Set Cel1 = Cel2
Adr = Cel2.Address
Do
'recherche la suivante
Set Cel2 = Plage.FindNext(Cel2)
'si c'est la fin
If Cel2.Address = Adr Then
'redéfini la dernière cellule
With Worksheets("Source")
Set Cel2 = Worksheets("Source").Cells(.Rows.Count, 2).End(xlUp)
Adr = Cel2.Address 'mémorise l'adresse pour sortir de la boucle
K = Cel2.Row + 1 'incrémente de 1 pour correspondre dans la boucle I
End With
Else
K = Cel2.Row
End If
'le plus long enregistrement faisant 7 champs
'on doit retourner systématiquement un tableau à 7 cellules
For I = 1 To 7
'nombre d'enregistrement
Select Case 7 - (K - Cel1.Row)
'cas où il y a 7 champs
Case Is = 0
Tbl(I) = Cel1.Offset(I - 1, -1)
'cas où il y a 6 champs
Case Is = 1
If I = 5 Then
Tbl(I) = ""
Else
J = J + 1
Tbl(I) = Cel1.Offset(J - 1, -1)
End If
'cas où il y a 5 champs
Case Is = 2
If I = 4 Or I = 5 Then
Tbl(I) = ""
Else
J = J + 1
Tbl(I) = Cel1.Offset(J - 1, -1)
End If
End Select
Next I
'défini la première ligne vide
L = Worksheets("Base").Cells(Rows.Count, 1).End(xlUp).Row + 1
J = 0
'colle les valeurs dans la feuille "Base"
'(la fonction "Transpose" me posant des problèmes ?)
For I = 1 To 7
J = J + 1
Worksheets("Base").Cells(L, J) = Tbl(I)
Next I
J = 0
'mémorise la cellule précédente
Set Cel1 = Cel2
Loop While Cel2.Address <> Adr
End If
End Sub