Découper une procédure en plusieurs

Bonjour,

J'ai du code avec des redondances

je cherche à découper la procédure en plusieurs (les parties qui sont dans les if)

Sub version1()

        derlig = Sheets("Feuil3").Range("A65000").End(xlUp).Row

        ReDim bb(1 To derlig * (6 + 20), 0) 'nv tblo

For i = 2 To 2

        If Cells(i, 1) & Cells(i, 3) & Cells(i, 5) = Cells(i + 1, 1) & Cells(i + 1, 3) & Cells(i + 1, 5) Then

            For j = 1 To 2
            c = c + 1
            bb(c, 0) = Cells(2, j)
            Next

            c = c + 1
            bb(c, 0) = "ajout1"

            For j = 3 To 4
            c = c + 1
            bb(c, 0) = Cells(2, j)
            Next

            c = c + 1
            bb(c, 0) = "ajout1"

             For j = 5 To 6
             c = c + 1
             bb(c, 0) = Cells(2, j)
             Next

        End If
Next

For i = 3 To derlig

        If Cells(i, 1) & Cells(i, 3) = Cells(i - 1, 1) & Cells(i - 1, 3) Then

             For j = 5 To 6
             c = c + 1
             bb(c, 0) = Cells(i, j)
             Next

        ElseIf Cells(i, 1) = Cells(i - 1, 1) Then

              For j = 3 To 4
            c = c + 1
            bb(c, 0) = Cells(i, j)
            Next

            c = c + 1
            bb(c, 0) = "ajout1"

             For j = 5 To 6
             c = c + 1
             bb(c, 0) = Cells(i, j)
             Next

         Else

            For j = 1 To 2
            c = c + 1
            bb(c, 0) = Cells(i, j)
            Next

            c = c + 1
            bb(c, 0) = "ajout1"

            For j = 3 To 4
            c = c + 1
            bb(c, 0) = Cells(i, j)
            Next

            c = c + 1
            bb(c, 0) = "ajout1"

             For j = 5 To 6
             c = c + 1
             bb(c, 0) = Cells(i, j)
             Next

        End If
Next

        Sheets("Feuil3").Cells(10, 1).Resize(c).Value = bb 'retranscrit nv tblo
End Sub