Correction bug dans mon code

Option Explicit
Public LaDate As String
Public Ws As Worksheet
'Public Pas As Double
Public NbTablo As Integer


Sub ImportPagePrincipale()
Dim I As Integer

  If IsDate(Range("D11")) Then
    Application.ScreenUpdating = False
    LaDate = Format(Range("D11"), "dd/mm/yyyy")
    
    Application.DisplayAlerts = False
    For I = Sheets.Count To 2 Step -1
      Sheets(I).Delete
    Next I
    Application.DisplayAlerts = True
    
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Import"
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "ImportReunions"
    
    Set Ws = Sheets("Import")
    
    ImportPage Ws.Name, "http://www.paris-turf.com/pid1-paris-turf-la-base-numero-1-du-turf.-tierce-quarte-quinte-pmu-pmh.html?date=" & LaDate
    Nettoyage
    Ws.Select
    
  End If
End Sub

Sub ImportTableaux()
Dim I As Integer

  Application.ScreenUpdating = False
  LaDate = Format(Range("D11"), "dd/mm/yyyy")
  UserForm1.Show 0
  Set Ws = Sheets("Import")

  NbTablo = Application.CountIf(Ws.Columns("H"), "x")
  If NbTablo > 0 Then
    LesReunions
    For I = 4 To Sheets.Count
      With Sheets(I).Cells
        .WrapText = False
        .EntireColumn.AutoFit
      End With
    Next I
    UserForm1.Height = 165
  End If
  Application.DisplayAlerts = False
  Sheets("Import").Delete
  Sheets("ImportReunions").Delete
  Application.DisplayAlerts = True
    
End Sub

Sub ImportPage(Feuille As String, Lien As String)
  
  UserForm1.Caption = Lien
  UserForm1.Repaint

  Shell "RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 8"
  Sheets(Feuille).Cells.Clear
  
  With Sheets(Feuille).QueryTables.Add(Connection:= _
              "URL;" & Lien, Destination:=Sheets(Feuille).Range("A1"))
    .Name = "2012"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = False
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlEntirePage
    .WebFormatting = xlWebFormattingAll
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
  End With
End Sub

Option Explicit

Sub Nettoyage()
Dim Cel As Range
Dim Depart As String
Dim LgDep As Long
Dim LgFin As Long
Dim Lgder As Long
Dim Ligne As Long

  Application.ScreenUpdating = False
  
  With Ws
    ' On supprime les lignes jusqu'à la 1ère occurence de la date
    Ligne = 1
    Do While InStr(1, .Range("A" & Ligne), LaDate) = 0
      .Rows(Ligne).Delete
    Loop
    
    Lgder = .Range("A" & Rows.Count).End(xlUp).Row
    
    ' On cherche la ligne qui est juste après le dernier tableau
    ' Et on efface de cette ligne jusqu'à la fin de la page
    Set Cel = .Columns("A").Find(what:="La base numéro 1 du Turf", LookIn:=xlValues, lookat:=xlWhole)
    If Not Cel Is Nothing Then
      .Rows(Cel.Row & ":" & Lgder).ClearContents
    Else
      MsgBox "Impossible de trouver le marqueur : La base numéro 1 du Turf"
      End
    End If
    
    ' Entre chaque titre des réunions et le tableau on efface les lignes
    Set Cel = .Columns("A").Find(what:=LaDate, LookIn:=xlValues, lookat:=xlPart)
    If Not Cel Is Nothing Then
      Depart = Cel.Address
      Do
        .Rows(Cel.Row + 1 & ":" & Cel.Row + 9).ClearContents
        Set Cel = .Columns("A").FindNext(Cel)
      Loop While Not Cel Is Nothing And Depart <> Cel.Address
    End If
    
    ' On efface toutes les lignes avec "fermer"
    Set Cel = .Columns("A").Find(what:="fermer", LookIn:=xlValues, lookat:=xlWhole)
    If Not Cel Is Nothing Then
      Depart = Cel.Address
      Do
        .Rows(Cel.Row).ClearContents
        Set Cel = .Columns("A").FindNext(Cel)
      Loop While Not Cel Is Nothing
    End If
    
    ' On supprime toutes les lignes vierges
    On Error Resume Next
    .Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    Lgder = .Range("A" & Rows.Count).End(xlUp).Row
  End With

End Sub

Option Explicit

Sub LesReunions()
Dim Feuille As String
Dim J As Long
Dim Lgder As Long
Dim WsImp As Worksheet
Dim Cel As Range
Dim Progression As Double
Dim Pas As Double

  Set WsImp = Sheets("ImportReunions")
  
  Lgder = Ws.Range("A" & Rows.Count).End(xlUp).Row
  Pas = (UserForm1.Label5.Width - 4) / NbTablo
  
  For J = 1 To Lgder
    'If J = 10 Then Exit Sub
    If InStr(1, Ws.Range("A" & J), LaDate) > 0 Then
      Feuille = Left(Ws.Range("A" & J), InStr(1, Ws.Range("A" & J), " -") - 1)
    Else
      If Ws.Range("B" & J).Hyperlinks.Count = 1 And Ws.Range("H" & J) = "X" Then
        Progression = Progression + Round((100 / NbTablo), 2)
        UserForm1.Label2.Caption = Val(UserForm1.Label2.Caption) + 1
        UserForm1.Label3.Caption = Progression & "%"
        UserForm1.Label4.Width = Val(UserForm1.Label2.Caption) * Pas
        UserForm1.Caption = Ws.Range("B" & J).Hyperlinks(1).Address
        UserForm1.Repaint
        
        ImportPage "ImportReunions", Ws.Range("B" & J).Hyperlinks(1).Address
        'Stop
        With WsImp
          Set Cel = .Columns("A").Find(what:="Origines", LookIn:=xlValues, lookat:=xlWhole)
          If Not Cel Is Nothing Then
            .Rows(Cel.Row & ":" & Rows.Count).Delete
          Else
            MsgBox "Impossible de trouver le marqueur : Origines"
            End
          End If
          
          Set Cel = .Columns("A").Find(what:="1er", LookIn:=xlValues, lookat:=xlWhole)
          If Not Cel Is Nothing Then
            .Rows("1:" & Cel.Row - 2).Delete
          Else
            MsgBox "Impossible de trouver le marqueur : 1er"
            End
          End If
          
          On Error Resume Next
          .Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
          On Error GoTo 0
          
          Lgder = .Range("A" & Rows.Count).End(xlUp).Row
          
          If FeuilleExiste(Feuille) = False Then
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = Feuille
          End If
          
          With .Range("A1:N" & Lgder)
            .Borders.Weight = xlThin
            .Copy Destination:=Sheets(Feuille).Range("A" & Rows.Count).End(xlUp).Offset(2, 0)
          End With
        End With
      End If
    End If
    
  Next J
  
End Sub


Function FeuilleExiste(Nom As String) As Boolean
  On Error Resume Next
  FeuilleExiste = Sheets(Nom).Name <> ""
  On Error GoTo 0
End Function

.Refresh BackgroundQuery:=False