Extraire une liste à partir d'un copier-coller de site

Sub Traitement_Compte1()
Sheets("Compte1").Select
Dim DerLigne As Long, ligne As Long
'Effacement des photos
  Dim img As Object
  For Each img In Sheets("Compte1").Shapes
  img.Delete
  Next
'suppression des lignes vides
  Range("A1:A65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Alignement à gauche
  Columns("A:A").Select
  With Selection
        .HorizontalAlignment = xlLeft
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'ajustement colonne
    Columns("A:A").Select
    Selection.Columns.AutoFit
'mise en bleu des lignes Compte1
  With Selection.Font
     .Color = -65536
     .TintAndShade = 0
  End With
End Sub
Sub Traitement_Compte2()
Sheets("Compte2").Select
'Effacement des photos
 Dim img As Object
 For Each img In Sheets("Compte2").Shapes
 img.Delete
 Next
'suppression des lignes vides
 Range("A1:A65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Alignement à gauche
  Columns("A:A").Select
  With Selection
        .HorizontalAlignment = xlLeft
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'ajustement colonne
    Columns("A:A").Select
    Selection.Columns.AutoFit
End Sub
Sub Compilation()
    Dim ShHoriz As Worksheet, ShVert As Worksheet, Compte1 As Worksheet, Compte2 As Worksheet
    Dim DerLig1 As Long, DerLig2 As Long
    
    Application.ScreenUpdating = False
    Set ShHoriz = Sheets("Liste Horizontale")
    Set ShVert = Sheets("Liste Verticale")
    
    'copie des élements de Compte1
     Sheets("Compte1").Select
     DerLig1 = Compte1.[A100000].End(xlUp).Row
     Range("A1:A&DerLig1").Select
     Selection.Copy
     Sheets("ShVert").Select
     ActiveSheet.Paste
    'copie des élements de Compte2
     Sheets("Compte2").Select
     DerLig2 = Compte2.[A100000].End(xlUp).Row
     Range("A1:A&DerLig2").Select
     Selection.Copy
     Sheets("ShVert").Select
     ShVert.Cells(DerLig1, "A").Select
     ActiveSheet.Paste
End Sub
Sub Reorganiser()
    Dim ShHoriz As Worksheet, ShVert As Worksheet
    Dim DerLig As Long, LigH As Long, LigV As Long, i As Long, NLigV As Long
    
    Application.ScreenUpdating = False
    Set ShHoriz = Sheets("Liste Horizontale")
    Set ShVert = Sheets("Liste Verticale")
    
    ShHoriz.Cells.ClearContents
    
    DerLig = ShVert.[A100000].End(xlUp).Row
    LigH = 2
    LigV = 1
    For i = 1 To DerLig
        ShHoriz.Cells(LigH, "B") = ShVert.Cells(LigV, "A") 'Intitulé
        If ShVert.Cells(LigV + 3, "A") = "Date" Then
            ShHoriz.Cells(LigH, "C") = ShVert.Cells(LigV + 1, "A")  'Prix
            ShHoriz.Cells(LigH, "D") = ShVert.Cells(LigV + 2, "A") 'Catégorie
            ShHoriz.Cells(LigH, "A") = Format(ShVert.Cells(LigV + 4, "A"), "mm/dd") 'Date
            ShHoriz.Cells(LigH, "E") = ShVert.Cells(LigV + 6, "A") 'Vues
            ShHoriz.Cells(LigH, "F") = ShVert.Cells(LigV + 7, "A") 'Tel
            ShHoriz.Cells(LigH, "G") = ShVert.Cells(LigV + 8, "A") 'Mails reçus
            LigV = LigV + 9
        Else
            ShHoriz.Cells(LigH, "D") = ShVert.Cells(LigV + 1, "A") 'Catégorie
            ShHoriz.Cells(LigH, "A") = Format(ShVert.Cells(LigV + 3, "A"), "mm/dd") 'Date
            ShHoriz.Cells(LigH, "E") = ShVert.Cells(LigV + 5, "A") 'Vues
            ShHoriz.Cells(LigH, "F") = ShVert.Cells(LigV + 6, "A") 'Tel
            ShHoriz.Cells(LigH, "G") = ShVert.Cells(LigV + 7, "A") 'Mails reçus
            LigV = LigV + 8
        End If
        LigH = LigH + 1
    Next
    'mise en place de la ligne des titres
    ShHoriz.Range("A1:G1").Value = Array("Date", "Intitulé", "Prix", "Catégorie", "Vues", "Tel", "mails reçus")
    'Mise en forme
    Cells.Select
    Selection.Columns.AutoFit
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:G1").Select
    Selection.Font.Bold = True
    Selection.Font.Underline = xlUnderlineStyleNone
    ShHoriz.Select
    
    'Columns("C:C").NumberFormat = "#,##0.00 $"
    Columns("C:C").NumberFormat = "#,##0"
  
'Tri par intitulés
     Cells.Select
    ActiveWorkbook.Worksheets("Liste Horizontale").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Liste Horizontale").Sort.SortFields.Add Key:=Range _
        ("B2:B1722"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Liste Horizontale").Sort
        .SetRange Range("A1:G1722")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
    Set ShHoriz = Nothing
    Set ShVert = Nothing
End Sub

   DerLig1 = Sheets("Compte1").[A100000].End(xlUp).Row

Set Cpt1=sheets("Compte1")
DerLig1 = ShCpt1.[A100000].End(xlUp).Row

For f = 1 To 2
        If i = 1 Then Set ShVert = Sheets("Pro") Else Set ShVert = Sheets("Perso")

Set ShVert = Sheets("Compte" & f)

If f = 1 Then Set ShVert = Sheets("Pro") Else Set ShVert = Sheets("Perso")