Problème Excel

Option Explicit

Sub test()
Dim TabloACE(), TabloBDF(), DrLig As Long, Lign As Long, Col As Integer
Dim IndicC As Integer, IndicL As Long
Dim Valeur As Integer
Dim i As Integer, j As Integer
Dim Cible1 As Variant, Cible2 As Variant, Cible3 As Variant

With Sheets("Sheet4")
'remplir la var TabloACE des données contenues en colonnes A, C & E
    IndicC = 3
    IndicL = Application.CountA(.Columns(1)) - 1
    ReDim TabloACE(1 To IndicC, 1 To IndicL)
    IndicC = 1
    IndicL = 1
    DrLig = .Range("A" & Rows.Count).End(xlUp).Row
    For Lign = 2 To DrLig
        If .Cells(Lign, 1) <> "" Then
            For Col = 1 To 6 Step 2
                TabloACE(IndicC, IndicL) = .Cells(Lign, Col)
                IndicC = IndicC + 1
            Next Col
            IndicC = 1
            IndicL = IndicL + 1
        End If
    Next Lign
'trier la variable tableau ACE
    Do
        Valeur = 0
        For i = 1 To UBound(TabloACE, 2) - 1
            If TabloACE(1, i) > TabloACE(1, i + 1) Then
                Cible1 = TabloACE(1, i)
                Cible2 = TabloACE(2, i)
                Cible3 = TabloACE(3, i)
                TabloACE(1, i) = TabloACE(1, i + 1)
                TabloACE(2, i) = TabloACE(2, i + 1)
                TabloACE(3, i) = TabloACE(3, i + 1)
                TabloACE(1, i + 1) = Cible1
                TabloACE(2, i + 1) = Cible2
                TabloACE(3, i + 1) = Cible3
                Valeur = 1
            End If
        Next i
    Loop While Valeur = 1
'remplir la var TabloBDF des données contenues en colonnes B, D & F
'si on trouve en colonne B une des valeurs de A
    IndicL = 1
    DrLig = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 1 To UBound(TabloACE, 2)
        For Lign = 2 To DrLig
            If TabloACE(1, i) = .Cells(Lign, 2) Then
                If i > 1 Then
                    If TabloACE(1, i) <> TabloACE(1, i - 1) Then
                        ReDim Preserve TabloBDF(1 To 3, 1 To IndicL)
                        TabloBDF(1, IndicL) = .Cells(Lign, 2)
                        TabloBDF(2, IndicL) = .Cells(Lign, 4)
                        TabloBDF(3, IndicL) = .Cells(Lign, 6)
                        IndicL = IndicL + 1
                    End If
                Else
                    ReDim Preserve TabloBDF(1 To 3, 1 To IndicL)
                    TabloBDF(1, IndicL) = .Cells(Lign, 2)
                    TabloBDF(2, IndicL) = .Cells(Lign, 4)
                    TabloBDF(3, IndicL) = .Cells(Lign, 6)
                    IndicL = IndicL + 1
                End If
            End If
        Next Lign
    Next i
End With
MsgBox IndicL
'restitution des données triées et réparties dans une nouvelle feuille
ThisWorkbook.Worksheets.Add
Lign = 1
With ActiveSheet
    .Cells(Lign, 1) = TabloACE(1, 1)
    .Cells(Lign, 3) = TabloACE(2, 1)
    .Cells(Lign, 5) = TabloACE(3, 1)
    For i = 1 To UBound(TabloBDF, 2)
        If TabloACE(1, 1) = TabloBDF(1, i) Then
            .Cells(Lign, 2) = TabloBDF(1, i)
            .Cells(Lign, 4) = TabloBDF(2, i)
            .Cells(Lign, 6) = TabloBDF(3, i)
            Lign = Lign + 1
        End If
    Next i
    For j = 2 To UBound(TabloACE, 2)
        .Cells(Lign, 1) = TabloACE(1, j)
        .Cells(Lign, 3) = TabloACE(2, j)
        .Cells(Lign, 5) = TabloACE(3, j)
        If TabloACE(1, j) <> TabloACE(1, j - 1) Then
            For i = 1 To UBound(TabloBDF, 2)
                If TabloACE(1, j) = TabloBDF(1, i) Then
                    .Cells(Lign, 2) = TabloBDF(1, i)
                    .Cells(Lign, 4) = TabloBDF(2, i)
                    .Cells(Lign, 6) = TabloBDF(3, i)
                    Lign = Lign + 1
                End If
            Next i
        End If
        Lign = Lign + 1
    Next j
    DrLig = .Range("B" & Rows.Count).End(xlUp).Row
    'suppression des lignes vides
    For Lign = 1 To DrLig
        If Application.CountA(.Rows(Lign)) = 0 Then
            .Rows(Lign).Delete
        End If
    Next
End With
End Sub