Macro test colonne et fusion des cellules

For i = 1 To Range('D65536').End(xlUp).Row 'de la ligne 1 à la dernière ligne de la colonne D
    If Cells(i, 4).Value = 1 Then
        Range('D' & i & ':J' & i).Select
        Selection.Merge
        ActiveCell.FormulaR1C1 = '2'
    End If
Next i

Sub fusions()
Dim c As Range
Dim cpt As Integer

'pour toutes cellules non vides de D'
For Each c In Range('D2:D' & Range('D65536').End(xlUp).Row)
    
    'Tester la valeur'
    If c.Value = 1 Then
        'Sélectionner dans affirmative'
        Range(Cells(c.Row, 4), Cells(c.Row, 10)).Select
        
        'Centrer et fusionner la sélection'
        With Selection
            .HorizontalAlignment = xlCenter
            .Merge
        End With
        'Changer la valeur de la cellule et compter + 1'
        c.Value = 2
        cpt = cpt + 1
    End If
'Recommencer'
Next c

Range('D2').Select
'message'
MsgBox cpt & ' lignes modifiées'

End Sub