Can this code be written to run faster

[Sharid]

My code below does what i need it to do, the only problem is that it is TOO SLOW to process 1000, took about 2.5hr plus.

I am very limited in coding and put this code together with part forum help and part coding myself.

What the code does
Process URL in sheet2, opens IE goes to CLASS "bio" and extracts the text, then pastes in sheet1. It deletes any duplicates and also if the rows do not contain an "@" it deletes that row from sheet1.

Could this code be written to run much faster.

I tried to move the deleting duplicates and deleting rows with out "@" to the end of the code, once IE had finished the url but it just froze for a very long time and then crashed. Hence it does this process everytime it pastes a url in sheet1.

Dim wb As Workbook
Dim x As Variant
Dim i, j, k, l As Integer
Dim r As Long, lr As Long
Dim wsSheet As Worksheet, links As Variant, ie As Object, link As Variant
Dim rw As Long

    i = 2
    k = 2
    l = 2
    'SHEET2 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("URL LIST")
    
    'Set IE = InternetExplorer
    Set ie = CreateObject("InternetExplorer.Application")
    
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A1:A" & rw)
    
    'IE Open Time per page 5sec and check links on Sheet2 Column A
    With ie
       .Visible = True
       Application.Wait (Now + TimeValue("00:00:5"))
       
       For Each link In links
           .navigate (link)
           While .Busy Or .readyState <> 4: DoEvents: Wend

Dim doc As HTMLDocument 'variable for document or data which need to be extracted out of webpage
Set doc = ie.document
Dim dd As Variant
dd = doc.getElementsByClassName("bio ")(0).innerText

'Paste in this sheet
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd
         
On Error Resume Next
                  
'Deletes duplicates in column A Sheet1
    Columns(1).RemoveDuplicates Columns:=Array(1)
    
'Deletes any rows in column A if it does not have a SPECIAL Character as shown in RED
    lr = Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
      For r = lr To 2 Step -1
        If InStr(Cells(r, 1), "@") = 0 Then Sheet1.Rows(r).Delete
      Next r
 
 ' Deletes any blank rows as data pased into excel as too many blank rows
    Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
'navigate links
       Next link
       
'Close IE Browser
    .Quit
    End With
    
    Set ie = Nothing

 

[Sharid]

Is it possible to improve this to run faster? or do I have to make do