Collage après filtre dans les cellules visibles

Sub Alignement()
Dim a, i As Long
    Application.ScreenUpdating = False
    With Sheets("Tableau2")
        a = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            .Item(Trim(a(i, 2))) = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
        Next
        With Sheets("Tableau1")
        ' A voir pour redéfinir la plage
            a = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value
        End With
        ReDim Preserve a(1 To UBound(a, 1), 1 To 6)
        For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 2)) Then
                If .exists(Trim(a(i, 2))) Then
                    a(i, 6) = .Item(Trim(a(i, 2)))(3)
                End If
            End If
        Next
        With Sheets("Feuil1").Cells(1)
            .CurrentRegion.Clear
            .Resize(, UBound(a, 2)).Value = [{"Niv","Référence","Type","Etape de fab","Coût de fab","Coût matière"}]
            .Offset(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
            With .CurrentRegion
                .Columns(1).Resize(, 4).HorizontalAlignment = xlCenter
                With .Rows(1)
                    .Font.Bold = True
                    .Interior.ColorIndex = 40
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                End With
                .Font.Name = "calibri"
                .VerticalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
            End With
            .Parent.Activate
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Sub Alignement1()
Dim a, i As Long
    Application.ScreenUpdating = False
    With Sheets("Tableau2")
        a = .Range("A1").CurrentRegion
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            .Item(Trim(a(i, 2))) = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
        Next
        With Sheets("Tableau1")
            a = .Range("A1").CurrentRegion
        End With
        ReDim Preserve a(1 To UBound(a, 1), 1 To 6)
        a(1, 6) = "Coût matière"
        For i = 2 To UBound(a, 1)
            If Not IsEmpty(a(i, 2)) Then
                If .exists(Trim(a(i, 2))) Then
                    a(i, 6) = .Item(Trim(a(i, 2)))(3)
                End If
            End If
        Next
        With Sheets("Feuil1").Cells(1)
            .CurrentRegion.Clear
            .Resize(UBound(a, 1), UBound(a, 2)).Value = a
            With .CurrentRegion
                .Columns(1).Resize(, 4).HorizontalAlignment = xlCenter
                With .Rows(1)
                    .Font.Bold = True
                    .Interior.ColorIndex = 40
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                End With
                .Font.Name = "calibri"
                .VerticalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .Columns(5).Resize(, 2).NumberFormat = "_ * #,##0.00 €_ ;_ * -#,##0.00 €_ ;_ * ""-""?? €_ ;_ @_ "
            End With
            .Parent.Activate
        End With
    End With
    Application.ScreenUpdating = True
End Sub