Web scrapping project - how to crawl websites using vba

Web scrapping project - how to crawl websites using vba

Sub DataScrap()

    Dim ie As InternetExplorer
    Dim httm As HTMLDocument
    
    Set ie = New InternetExplorer
    ie.Visible = True
    ie.Navigate "https://quotes.toscrape.com/"
    Do While ie.ReadyState <> READYSTATE_COMPLETE Or ie.Busy = True: Loop
    Application.Wait Now() + TimeValue("00:00:03")
    
    Set htm = ie.Document
    
    Call WriteHeading
    Call HTMLDoc(htm, ie)
    
    ie.Quit
End Sub


Sub HTMLDoc(ByVal doc As HTMLDocument, ByVal tmpIE As InternetExplorer)

    Dim varData(1 To 2) As Variant
    Dim i As Integer
    Dim d As Integer
    i = doc.getElementsByClassName("col-md-8")(1).getElementsByClassName("quote").Length - 1
    
    Do While doc.getElementsByClassName("next").Length = 1
        
        For d = 0 To i
            varData(1) = doc.getElementsByClassName("col-md-8")(1).getElementsByClassName("quote") _
            (d).getElementsByClassName("author")(0).innerText
            
            varData(2) = doc.getElementsByClassName("col-md-8")(1).getElementsByClassName("quote") _
            (d).getElementsByClassName("text")(0).innerText
            
            Call WriteData(varData)
        Next d
        
        doc.getElementsByClassName("next")(0).getElementsByTagName("a")(0).Click
        Do While tmpIE.ReadyState <> READYSTATE_COMPLETE Or tmpIE.Busy = True: Loop
        Application.Wait Now() + TimeValue("00:00:03")
        
    Loop
    
    For d = 0 To i
        varData(1) = doc.getElementsByClassName("col-md-8")(1).getElementsByClassName("quote") _
        (d).getElementsByClassName("author")(0).innerText
        
        varData(2) = doc.getElementsByClassName("col-md-8")(1).getElementsByClassName("quote") _
        (d).getElementsByClassName("text")(0).innerText
        
        Call WriteData(varData)
    Next d
        
End Sub


Sub WriteHeading()

    Dim FileName As String
    Dim F1 As Integer
    
    FileName = ThisWorkbook.Path & "\" & "data.csv"
    F1 = 1
    
    If Len(Dir(FileName)) = 0 Then
        Open FileName For Output As #F1
            Write #F1, "Author", "Content"
        Close #F1
    End If
    
End Sub


Sub WriteData(ByVal data As Variant)

    Dim FileName As String
    Dim F1 As Integer
    
    FileName = ThisWorkbook.Path & "\" & "data.csv"
    F1 = 1
    
    Open FileName For Append As #F1
        Write #F1, data(1),
        Write #F1, data(2)
    Close #F1
    
End Sub

Subscribe my Channel

Akash Vishwakarma

Hi This is Akash Vishwakarma. I am working as software developer. I have knowledge in VBA, SQL Server, Python. I have developed this website from Django Framework for given traning.