Sub recouper()
Dim tablo() As Variant
NbCarac = InputBox("Donnez le nombre de caractères à prendre en compte pour les correspondances")
With ActiveSheet
tablo = .UsedRange.Offset(1, 0).Value
End With
FusionDone = False
Encore = False
For i = LBound(tablo, 1) To UBound(tablo, 1) - 1
If Left(tablo(i, 2), NbCarac) Like Left(tablo(i + 1, 2), NbCarac) And Left(tablo(i, 3), NbCarac) Like Left(tablo(i + 1, 3), NbCarac) And tablo(i, 6) = tablo(i + 1, 6) Then
'tablo(i + 1, 1) = tablo(i, 1)
' tablo(i, 1) = ""
FusionDone = True
For j = LBound(tablo, 2) To UBound(tablo, 2)
If tablo(i, j) = "" Xor tablo(i + 1, j) = "" Then
tablo(i + 1, j) = tablo(i, j) & tablo(i + 1, j)
Else
tablo(i + 1, j) = tablo(i + 1, j)
End If
Next j
tablo(i, 1) = ""
ElseIf tablo(i, 1) = "" Then
tablo(i, 1) = "NON fusionné"
Encore = True
End If
Next i
With ActiveSheet
If FusionDone Then
.Range("A2").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
.Range("A2").Resize(UBound(tablo, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = 2 To .UsedRange.Rows.Count
If .Range("A" & i) = "NON fusionné" Then .Range("A" & i) = ""
Next i
End If
End With
If Encore Then MsgBox ("Il reste des lignes à fusionner, diminuez le nombre de caractères")
End Sub