Excel : Copier des cellules liées

Sub supp() 
    Dim lig As Long 
    For lig = [A65536].End(xlUp).Row To 2 Step -1 
        If Cells(lig, 1) = 0 Then Cells(lig, 1).Resize(1, 2).Delete Shift:=xlUp 
    Next lig 
End Sub

Sub lister_sans_0() 
Dim derlig As Long 
Dim tablo 

derlig = Range("A65536").End(xlUp).Row 
ReDim tablo(0) 

For Cptr = 1 To derlig 
If Cells(Cptr, 1) <> 0 Then 
    tablo(cptr_T) = Cells(Cptr, 1) 
    cptr_T = cptr_T + 1 
    ReDim Preserve tablo(cptr_T) 
End If 
Next 

Columns(2).ClearContents 
Range("B1").Resize(cptr_T + 1, 1) = Application.Transpose(tablo) 
     
End Sub

Sub lister_sans_0()
Dim derlig As Integer, cptr As Integer, cptr_t As Integer
Dim tablo

'initialisations
derlig = Range("A65536").End(xlUp).Row
ReDim tablo(1, 0)

'colecte des données
For cptr = 2 To derlig
If Cells(cptr, 1) <> 0 Then
    tablo(0, cptr_t) = Cells(cptr, 1)
    tablo(1, cptr_t) = Cells(cptr, 2)
    cptr_t = cptr_t + 1
    ReDim Preserve tablo(1, cptr_t)
End If
Next

'restitution
Application.ScreenUpdating = False
Range("C2:D30000").ClearContents
Range("C2").Resize(cptr_t + 1, 2) = Application.Transpose(tablo)
 Application.ScreenUpdating = True

End Sub