Click here to Skip to main content
13,703,250 members
Rate this:
 
Please Sign up or sign in to vote.
See more:
Hi
In Instagarm URLs (pages) Some Information is available everyone . Some of them are javascript
for example : https://www.instagram.com/leomessi/
For each url And for each media There are identical codes
for example :
"display_url":"https://scontent-frt3-1.cdninstagram.com/vp/......jpg",
"edge_liked_by":{"count":3772041},
"edge_media_preview_like":{"count":3772041},

How can it be Coding VBA To extract numbers (liked and preview) and this information to the Sheet 1
On the page there are usually 24 post . but I want the count for the last 6 posts.


in below code i just scrap html but j.s i have problem

best regard

What I have tried:

Sub macro1()

    Dim wb As Object
    Dim doc As Object
    Dim sURL As String
  ' Dim LastRow As Long
    Dim n As Integer
    Dim I As Integer
    Dim HtmlToText As String
    Dim result
   Dim start As Variant
    Dim LastRow As Variant
  ' LastRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row



    start = InputBox("ÔãÇÑå ÑÏíÝ ÂÛÇÒ")
    LastRow = InputBox("ÔãÇÑå ÑÏíÝ ÇíÇä")

    For I = start To LastRow
   'For I = 2 To 10

 
  
   On Error Resume Next
            
 
        Set wb = CreateObject("internetExplorer.Application")
        sURL = Cells(I, 2)
        wb.navigate sURL
        wb.Visible = False
        While wb.Busy
          DoEvents
        Wend
   

        
        'HTML document
        Set doc = wb.document
        Dim Name As Variant
        Dim Posts As Variant
        Dim Follows As Variant
        Dim Following As Variant
        Dim DivValue As Variant
        Dim DivValueSplit As Variant
        Dim DivValueResult As Variant
        Dim Biography As Variant
        
            Do
    If wb.readyState = READYSTATE_COMPLETE Then
        If wb.document.readyState = "complete" Then Exit Do
    End If
    Application.Wait DateAdd("s", 10, Now)
Loop



Application.ScreenUpdating = False
Dim cRow    As Long
Dim lstrow  As Long
lstrow = Range("A" & Rows.Count).End(xlUp).Row
cRow = WorksheetFunction.Min(Range("A" & Rows.Count).End(xlUp).Row, Range(ActiveCell.Address).Offset(1, 0).Row)
If cRow = Range("A" & Rows.Count).End(xlUp).Row Then cRow = 2
Range("A" & cRow).Activate
ActiveWindow.ScrollRow = 1
Application.Goto ActiveCell, True
Range("A" & cRow).Show
Application.ScreenUpdating = True


        Name = doc.getElementsByClassName("AC5d8 notranslate")(0).innerText
        Posts = doc.getElementsByClassName("g47SY")(0).innerText
        Followers = doc.getElementsByClassName("g47SY")(1).Title
        Following = doc.getElementsByClassName("g47SY")(2).innerText
        DivValue = doc.getElementsByClassName("-vDIg")(0).innerText
        
wb.Quit
        Worksheets("sheet1").Cells(I, 6) = Name
        Worksheets("sheet1").Cells(I, 7) = Followers
        Worksheets("sheet1").Cells(I, 8) = Following
        Worksheets("sheet1").Cells(I, 9) = Posts
        Worksheets("sheet1").Cells(I, 10) = DivValue
        Biography = Replace(re1, "<span>", "")

wb.Quit

err_clear:
        If Err <> 0 Then
          Err.Clear
          Resume Next
        End If
        wb.Quit
Sheet1.Range("J2").WrapText = True
 Next I
      Worksheets("sheet1").Columns("J:J").WrapText = False

End Sub


Sub scroll()
Application.ScreenUpdating = False
Dim cRow    As Long
Dim lstrow  As Long
lstrow = Range("A" & Rows.Count).End(xlUp).Row
cRow = WorksheetFunction.Min(Range("A" & Rows.Count).End(xlUp).Row, Range(ActiveCell.Address).Offset(5, 0).Row)
If cRow = Range("A" & Rows.Count).End(xlUp).Row Then cRow = 2
Range("A" & cRow).Activate
ActiveWindow.ScrollRow = 5
Application.Goto ActiveCell, True
Range("A" & cRow).Show
Application.ScreenUpdating = True
End Sub
Posted 4 days ago
Updated 2 days ago
v2

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

  Print Answers RSS
Top Experts
Last 24hrsThis month


Advertise | Privacy | Cookies | Terms of Service
Web06-2016 | 2.8.180906.1 | Last Updated 18 Sep 2018
Copyright © CodeProject, 1999-2018
All Rights Reserved.
Layout: fixed | fluid

CodeProject, 503-250 Ferrand Drive Toronto Ontario, M3C 3G8 Canada +1 416-849-8900 x 100