CODEWITHSUNDEEP
excelvbaloopsscreen-scraping
JAYK
JAYK

Reputation: 15

web scraping using vba without rerunning each input in given range

I am solving the following issue: I want to scrape a title of website when link inserted in column A and put this value to relevant cell (next to it) in column B. The issue seems to be that once I paste the website in column A, the code reruns the entire list from column A2 to "last row" as defined in the code. Is there any way to only modify column B once a single column A is modified? I.e. if I paste a link in column A36 I get a title in B36, regardless of whether the cell is in the middle of the used range or at the very bottom (i.e. only that very cells gets affected..) I would like to use this without having to re-run multiple inputs as it currently stands; (i.e. the loop "for i =2 to last row")? Also, I would like to change the below from Modular macro i.e. sub to private sub reacting to change (i.e. intersect function) where the 'target' is any cell from A:A range. Many thanks!

enter code here

Sub get_title_header()

Dim wb As Object
Dim doc As Object
Dim sURL As String
Dim lastrow As Long
lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).row

For i = 2 To lastrow
Set wb = CreateObject("internetExplorer.Application")
sURL = Cells(i, 1)

wb.navigate sURL
wb.Visible = False

While wb.Busy
DoEvents
Wend

''HTML document
Set doc = wb.document

Cells(i, 2) = doc.Title

On Error GoTo err_clear
Cells(i, 3) = doc.GetElementsByTagName("h1")(0).innerText
err_clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
wb.Quit
Range(Cells(i, 1), Cells(i, 3)).Columns.AutoFit
Next i

End Sub

Upvotes: 0

Views: 85

Answers (1)

YasserKhalil
YasserKhalil

Reputation: 9548

Put the code in worksheet change event (Right-click on the sheet tab >> View Code >> Paste the code)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ie As Object, doc As Object, sURL As String
If Target.Cells.CountLarge > 1 Then Exit Sub
If Target.Column = 1 Then
    Set ie = CreateObject("internetExplorer.Application")
    sURL = Target.Value

    With ie
        .navigate sURL
        .Visible = False
        While .Busy: DoEvents: Wend
        Set doc = .document
    End With

    Target.Offset(, 1).Value = doc.Title
    On Error GoTo errClear
    Target.Offset(, 2).Value = doc.getElementsByTagName("h1")(0).innerText

errClear:
    If Err <> 0 Then Err.Clear: Resume Next
    ie.Quit
    Set ie = Nothing
    Application.Wait Now + TimeValue("00:00:03")
    Columns("A:C").AutoFit
End If
End Sub

Upvotes: 2

Related Questions