Copie Tableau d'un Feuil et envoie par mail

Private Sub CommandButton3_Click() 'COURRIER OU VERIF
Dim OutApp As Object, OutMail As Object
Dim Debut$, Fin$
Dim rng As Range
Dim i&, j&
  With Application
    .EnableEvents = 0
    .ScreenUpdating = 0
  End With
  Sheets.Add After:=Sheets(Sheets.Count)
  j = 2
  With Sheets(1)
    Rows(1).Copy .Rows(1)
    For i = 2 To [A65536].End(xlUp).Row
      If Cells(i, 1) = "COURRIER" Then 'Or .Cells(i, 1) = "VERIF"' POUR 2 CRITERE
        Rows(i).Copy .Rows(j)
        j = j + 1
      End If
    Next
  End With
  
  Set rng = Nothing
  On Error Resume Next
  Set rng = Range("A1:C" & [A65536].End(xlUp).Row)
  On Error GoTo 0
  If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
      vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
  End If
  Debut = "Bonjour , <BR>.<BR>"
  Fin = "<BR>.<BR>"
    
  Set OutApp = CreateObject("Outlook.Application")
  OutApp.Session.Logon
  Set OutMail = OutApp.CreateItem(0)
    
  On Error Resume Next
  With OutMail
    .To = "xxxxxxxxxx@romandie.com"
    .CC = "xxxxxxxxxxx@hotmail.com"
    .BCC = ""
    .Subject = "COURRIER DU " & Cells(1, 1)
        
    .HTMLBody = Debut & RangetoHTML(rng) & Fin
        
    .Display
      '.Send
  End With
  On Error GoTo 0
 
  Set OutMail = Nothing
  Set OutApp = Nothing
  Application.DisplayAlerts = 0
  ActiveSheet.Delete

MsgBox "COURRIER ENVOYES"
  With Application
    .EnableEvents = -1
    .ScreenUpdating = -1
    .DisplayAlerts = -1
  End With
End Sub