Fusion de 2 lignes

'Cette procédure fusionne les lignes de la feuille courante quand le contenu de 2 cellule consécutive est identique
'Le numéro de la colonne des cellules à comparé est contenu dans la variable NumColTest
'Pour fonctionner, le contenu cette colonne doit avoir été triés
'Dans la fusion, le contenu de chaque cellule de la ligne de dessous est concaténé avec un espace au contenu de la cellule au dessus, si le contenu des cellules est différent
'La première ligne est sensé contenir les titres de colonnes et toutes les cellules y doivent être remplie (sinon vous risquez de rater une partie des cellules)
Sub FusionneLignes()
Dim NumColTest As Integer 'Numéro de la colonne à tester
Dim NumDerLi As Integer 'Numéro de la dernière ligne
Dim NumDerCol As Integer 'Numéro de la dernière colonne
Dim I As Integer 'Indice de boucle
Dim J As Integer 'Indice de boucle

'Désactive le raffraîchissement de l'écran
Application.ScreenUpdating = False

NumColTest = 8 'Colonne H

    'Recherche de la dernière ligne de la colonne à tester
    NumDerLi = Columns(NumColTest).Find("*", , , , , xlPrevious).Row
    'Recherche de la dernière ligne de la colonne à tester
    NumDerCol = Rows(1).Find("*", , , , , xlPrevious).Column
'MsgBox NumDerLi & "-" & NumDerCol
'Exit Sub
    ' boucle qui commence à la fin à cause des suppression de lignes


    For I = NumDerLi To 2 Step -1
      'Si la valeur de la cellule au dessus est égale à la valeur de la cellule courante alors
      If Cells(I, NumColTest) = Cells(I - 1, NumColTest) Then
      'On parcours la ligne en concaténant chaque cellule si elle sont différentes
      For J = 1 To NumDerCol
        If Trim(Cells(I - 1, J)) <> Trim(Cells(I, J)) Then
            'Evite d'insérer un espace si une des cellule n'a pas de contenu
            If Cells(I - 1, J) = "" Or Cells(I, J) = "" Then
                Cells(I - 1, J) = Cells(I - 1, J) & Cells(I, J)
            Else
                Cells(I - 1, J) = Cells(I - 1, J) & " " & Cells(I, J)
            End If
        End If
      Next J
      Rows(I).Delete
      End If
    Next
'Active le raffraîchissement de l'écran
Application.ScreenUpdating = True
End Sub