Problème lenteur macro

Dim Col%, tc, ligne&, m&, n&
    Dim champs As Range
    Dim C As Range
    Dim T()
    Dim a, x As Long
    
    
    tc = Array(3, 6, 9)
    Range("A:A").ClearContents
    a = -1
    For n = 0 To UBound(tc)
        
        Col = Val(tc(n))
        
        Set champs = Range(Cells(3, Col), Cells(5000, Col))
        Set C = champs.Find("?", , xlValues)
        If Not C Is Nothing Then
            adrdeb = C.Address
            Do
                a = a + 1
                ReDim Preserve T(a)
                T(a) = C.Value
                Debug.Print C.Value
                Set C = champs.FindNext(C)
            Loop While Not C Is Nothing And C.Address <> adrdeb
        End If
    Next n
    application.screenupdating=false
    Range("A:A").Clear
    For x = 0 To a
        Range("A" & x + 1) = T(x)
    Next x
application.screenupdating=true