XL 2013 (RESOLU) copier 4 listes dans une seule liste

Sub AR_Ray_Charles()
Dim vArr
With Application
    vArr = _
    Split(Join(.Transpose(Feuil1.Range("C2", Feuil1.Cells(Rows.Count, "C").End(3))), "²") & "²" & _
    Join(.Transpose(Feuil2.Range("C2", Feuil2.Cells(Rows.Count, "C").End(3))), "²") & "²" & _
    Join(.Transpose(Feuil3.Range("C2", Feuil3.Cells(Rows.Count, "C").End(3))), "²") & "²" & _
    Join(.Transpose(Feuil4.Range("C2", Feuil4.Cells(Rows.Count, "C").End(3))), "²"), "²")
    Feuil5.Range("A2").Resize(UBound(vArr)).Value = .Transpose(vArr)
End With
Feuil5.Columns(1).RemoveDuplicates 1, 1
End Sub

Sub test_C()
Dim f As Worksheet, dl&
For Each f In Worksheets
If f.Name <> "Finale" Then
Set r = f.Columns("C:C").SpecialCells(xlCellTypeConstants, 2)
Set rr = r.Offset(1).Resize(r.Rows.Count - 1)
rr.Copy Sheets("Finale").Cells(Rows.Count, 1).End(3)(2)
End If
Next
With Sheets("Finale")
    .Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    .[B1] = "TRI"
    dl = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("B2:B" & dl).FormulaR1C1 = "=DATEVALUE(CHOOSE(LEFT(RC[-1])*1,""1/1/"",""1/4/"",""1/7/"",""1/10/"")&RIGHT(RC[-1],4))"
    .Range("A1:B" & dl).Sort key1:=.Range("B2"), Order1:=xlAscending, Header:=xlYes
    .Range("B:B").Clear
End With
End Sub

Sub test_D()
Dim f As Worksheet, dl&
For Each f In Worksheets
    If f.Name <> "Finale" Then
        With f.Columns("C:C").SpecialCells(2, 2)
        .Offset(1).Resize(.Rows.Count - 1).Copy Sheets("Finale").Cells(Rows.Count, 1).End(3)(2)
        End With
    End If
Next
With Sheets("Finale")
    .Columns("A:A").RemoveDuplicates 1, 1: .[B1] = "TRI"
    dl = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("B2:B" & dl).FormulaR1C1 = "=DATEVALUE(CHOOSE(LEFT(RC[-1])*1,""1/1/"",""1/4/"",""1/7/"",""1/10/"")&RIGHT(RC[-1],4))"
    .Range("A1:B" & dl).Sort key1:=.Range("B2"), Order1:=1, Header:=1: .Range("B:B").Clear
End With
End Sub

Sub Test_E()
Dim x As Worksheet, rng As Range, k&, F As Worksheet: Set F = Sheets("Finale")
k = 1
For Each x In Worksheets
    If x.Name <> "Finale" Then
    x.Columns(3).Copy Sheets("Finale").Cells(1, k): k = k + 1
    End If
Next
Set dico = CreateObject("Scripting.Dictionary")
F.Cells(1).Resize(, 4) = "Liste Finale"
    For Each rng In F.Cells(1).CurrentRegion
        If rng.Value <> "" Then dico(rng.Value) = ""
    Next
F.Cells.Clear
F.Cells(1).Resize(dico.Count) = Application.Transpose(dico.Keys)
F.Cells(1).CurrentRegion.Borders.Value = 1
End Sub