Ranger par mois une liste de facture.

Sub FactureParMois()
    Dim MonDico As Object, Item As Variant, DerL As Long, L As Long, Li As Long

    Set MonDico = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False

    With Sheets("Synthèse")
        DerL = .Range("B65535").End(xlUp).Row
        For L = DerL To 2 Step -1
            If .Range("B" & L) = "" Then
                .Rows(L).Delete
            End If
        Next

        For L = 2 To DerL
            If .Range("B" & L).Value <> "" And Not MonDico.Exists(Month(.Range("B" & L).Value)) Then MonDico.Add Month(.Range("B" & L).Value), Month(.Range("B" & L).Value)
        Next L

        .Range("B2:B" & DerL).NumberFormat = "mm"
        For Each Item In MonDico.items
            Set cel = .Range("B1:B" & .Range("B65535").End(xlUp).Row).Find(Item, LookIn:=xlValues)
            If Not cel Is Nothing Then
                Li = cel.Row
                .Rows(Li).Insert
                If Li = 2 Then
                    .Range("A" & Li & ":S" & Li).Interior.ColorIndex = xlNone
                    .Range("A" & Li).Font.Bold = False
                End If
                .Range("A" & Li).HorizontalAlignment = xlCenter
                .Range("A" & Li) = Format(Format(cel, "dd/mm/yyyy"), "mmmm")
            End If
        Next Item
        .Range("B2:B" & .Range("B65535").End(xlUp).Row).NumberFormat = "dd/mm/yyyy"
    End With
    Application.ScreenUpdating = True

End Sub