Comment eliminer les lignes vides

Sub Supprimer_Lignes_Vides()
Dim i As Long
For i = Range("A65536").End(xlUp).Row To 1 Step -1
    If IsEmpty(Cells(i, 1).Value) Then Rows(i).Delete
Next i
End Sub

Dim fichier$, Chemin$, source As Workbook, cible As Workbook
Dim lig%, dlg%, x&, i&, fin&
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path
Set cible = ThisWorkbook
fichier = Chemin & "\Reims\Suivi Camionnage.xls"
fin = Sheets("SD").Range("A65536").End(xlUp).Row
For i = 2 To fin
    If fichier Like "*" & Sheets("SD").Cells(i, 1) & "*" Then x = Sheets("SD").Cells(i, 2): GoTo 1
Next i
1
On Error Resume Next
Set source = Workbooks.Open(fichier)
On Error GoTo 0
    With source.Sheets("Données")
        [COLOR="Red"]Intersect(.Usedrange, .range("A3:A2000")).SpecialCells(xlcelltypeBlanks).EntireRow.Delete[/COLOR]
        dlg = cible.Sheets("Données").Range("A65536").End(xlUp).Row + 1
        lig = .Range("A3:A2000").Find("", , xlValues, , 1, 1, 0).Row
        Application.DisplayAlerts = False
            .Range("A4:M" & lig).Copy
            cible.Sheets("Données").Range("B" & dlg).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        cible.Sheets("Données").Range("A" & dlg & ":A" & dlg + lig - 5) = x
        cible.Sheets("Données").Range("A4:N" & dlg + lig - 5).Font.Name = "Times New Roman"
        cible.Sheets("Données").Range("A4:N" & dlg + lig - 5).Font.Bold = False
    End With
source.Close SaveChanges:=False
Application.DisplayAlerts = True
 Unload Agence
MsgBox "Traitement effectué", , "Importation du fichier Reims"