Code runs too slow, can it be improved

[Sharid]

Hi can somebody please help

Can this code be written better, so it processes the URL faster, it took almost 3 hours to process 1000 URL


What the code does
I have a url list in Sheet2 "URL LIST" which it uses to process and then puts result in Sheet1

[COLOR=#ff0000]'Count url in sheet2[/COLOR]
With Worksheets("URL LIST")
      lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
           Sheets("URL LIST").Range("L1").Value = lastRow
      End With
  
[COLOR=#ff0000]' Run main code[/COLOR]
 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
[COLOR=#ff0000]    'SHEET2 as sheet with URL[/COLOR]
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("URL LIST")
    
[COLOR=#ff0000]    'Set IE = InternetExplorer[/COLOR]
    Set ie = CreateObject("InternetExplorer.Application")
    
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A1:A" & rw)
    
[COLOR=#ff0000]    'IE Open Time per page 5sec and check links on Sheet2 Column A[/COLOR]
    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 [COLOR=#ff0000]'variable for document or data which need to be extracted out of webpage[/COLOR]
Set doc = ie.document
Dim dd As Variant
On Error Resume Next
dd = doc.getElementsByClassName("[COLOR=#0000cd]PUT CLASS HERE[/COLOR]")(0).Children(0).href
On Error Resume Next


[COLOR=#ff0000]'Paste in this sheet[/COLOR]
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd
         
[COLOR=#ff0000]'Deletes duplicates in column A Sheet1[/COLOR]
    'Columns(1).RemoveDuplicates Columns:=Array(1)
    
[COLOR=#ff0000] ' Put no1 in sheet2 column F[/COLOR]
  Sheets("URL LIST").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
 
[COLOR=#ff0000] 'Count No1 in sheet2 Column F[/COLOR]
With Worksheets("URL LIST")
    lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
    Sheets("URL LIST").Range("L2").Value = lastRow
    End With


[COLOR=#ff0000]'Click CommandButton9 [/COLOR]
Call CommandButton9_Click


[COLOR=#ff0000]'navigate links[/COLOR]
       Next link
       
[COLOR=#ff0000]'Close IE Browser[/COLOR]
    .Quit
    End With
    
    Set ie = Nothing

Thanks for having a look

 

[Sharid]

I check online yesterday before posting, found the first link. I tried that the code ran but would not extract and href and place them into sheet 1.

With the new bit you have just give anain same issue, gode runs well, but not href are extracted and placed into sheet1

    Dim LR      As Long
    Dim x       As Long
    Dim arr()   As Variant
    
    Dim wks     As Worksheet: Set wks = ThisWorkbook.Sheets("URL LIST")
    Dim ie      As Object: Set ie = CreateObject("InternetExplorer.Application")
    Dim doc   As HTMLDocument 'variable for document or data which need to be extracted out of webpage

'Dim doc     As HTMLDocument: Set doc = ie.document

    Dim dd      As Variant
    
    Application.ScreenUpdating = False
    
    With wks
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(1, 12).Value = LR
        arr = .Cells(1, 1).Resize(LR).Value
    End With
    
    With ie
        .Visible = True
        Application.Wait Now + TimeValue("0:00:4")
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            .navigate arr(x, 1)
            While .Busy Or .readyState <> 4: DoEvents: Wend
            
            On Error Resume Next
            With Sheet1
                LR = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row
                .Cells(LR, 1).Value = doc.getElementsByClassName("mbg")(0).Children(0).href
                .Cells(1, 1).Resize(LR).RemoveDuplicates Columns:=Array(1)
            End With
            On Error GoTo 0
            
            
            wks.Cells(wks.Cells(Rows.Count, 6).End(xlUp).Offset(1).Row).Value = 1
            wks.Cells(2, 12).Value = Application.CountIf(wks.Cells(1, 1).Resize(LR), 1)
            
             
            Call CommandButton9_Click
        Next x
        .Quit
    End With
    
    'Set arr = Nothing
    'Set wks = Nothing
    'Set ie = Nothing
    'Set doc = Nothing

 

[JackDanIce]

I'm afraid I don't know what else to suggest. My use of IE within VBA is limited; based on what you've posted or I've found online.

If you can provide one link, it could help to mock a spreadsheet here to see if the problem can be replicated otherwise, hopefully someone else reading can spot any code issues and advise.

 

[Sharid]

Thank for your support, like I said your code runs alot faster than mine. its just not pulling the href to sheet1

 

[JackDanIce]

It's a partial solution then! Glad it sort of helps and good luck resolving the other issue

 

[Sharid]

Got it working made a few changes. Thanks for your support JackDanIce

Private Sub CommandButton13_Click()
    Dim LR      As Long
    Dim x       As Long
    Dim arr()   As Variant
    
    Dim wks     As Worksheet: Set wks = ThisWorkbook.Sheets("URL LIST")
    Dim ie      As Object: Set ie = CreateObject("InternetExplorer.Application")
    
Dim dd As Variant
On Error Resume Next
    Application.ScreenUpdating = False
    
    With wks
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Cells(1, 12).Value = LR
        arr = .Cells(1, 1).Resize(LR).Value
    End With
    
    With ie
        .Visible = True
        Application.Wait Now + TimeValue("0:00:0")
        
        For x = LBound(arr, 1) To UBound(arr, 1)
            .navigate arr(x, 1)
            While .Busy Or .readyState <> 4: DoEvents: Wend
            
            On Error Resume Next
            
  Dim doc As HTMLDocument 'variable for document or data which need to be extracted out of webpage
     Set doc = ie.document
     dd = doc.getElementsByClassName("mbg")(0).Children(0).href
On Error Resume Next

'Paste in this sheet
Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row + 1, "A").Value = dd
             
            ' Put no1 in sheet2 column F
  Sheets("URL LIST").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = 1
  
 'Deletes duplicates in column A Sheet1
            Columns(1).RemoveDuplicates Columns:=Array(1)
 
 'Count No1 in sheet2 Column F
With Worksheets("URL LIST")
    lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
    Sheets("URL LIST").Range("L2").Value = lastRow
    End With
             
            Call CommandButton9_Click
        Next x
        .Quit
    End With
    
End Sub