Find automatically text in url and add information to excel

[Muskeetior]

Hello,

If i have in A1 url of youtube https://www.youtube.com/watch?v=cl3b7dDBLpo
I want add automaticly from url to excel B1 views [COLOR=rgba(17, 17, 17, 0.6)]91 800 997 [/COLOR]and to C1 automaticly posting date 2013-07-15.

 

[yky]

Try this. It has no error handling or annotation.

Option Explicit
Sub main()

scrape_youtube


End Sub
Sub scrape_youtube()

'
Dim IE As Object
Dim lastrow As Integer

On Error Resume Next

    Set IE = GetObject("InternetExplorer.Application")
If IE Is Nothing Then Set IE = CreateObject("INTERNETEXPLORER.APPLICATION")

Get_Info_From_Web IE, ThisWorkbook.Sheets("Sheet1").Range("A1")

extract_def

    IE.Quit

End Sub
Sub Get_Info_From_Web(ByRef IE As Object, ByVal lookup_word)
    
    With IE
        .Navigate lookup_word
        IE.Visible = True

        Do Until .ReadyState = 4: DoEvents: Loop
    End With
DoEvents

With IE.Document.getElementsByTagName("Body")(0)
    
    .Focus

End With

    IE.ExecWB 17, 0 '// SelectAll
    IE.ExecWB 12, 2 '// Copy selection
    ThisWorkbook.Sheets("Sheet2").Range("A1").Select
    ThisWorkbook.Sheets("Sheet2").PasteSpecial link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True

    IE.Quit

End Sub

Sub extract_def()

 Const Views = " views"
 Const PublishedOn = "Published on "

Dim rng As Range
Dim ViewsRow As Integer
Dim PublishedOnRow As Integer
Dim lastrow As Integer

PublishedOnRow = 0
ViewsRow = 0

With Sheets("Sheet2")

lastrow = .Range("A55555").End(xlUp).Row

Set rng = .Range("A:A").Find(What:=PublishedOn, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)

If Not rng Is Nothing Then
PublishedOnRow = rng.Row
Else
MsgBox ("Cannot find published date.")

End If

Set rng = .Range("A:A").Find(What:=Views, LookIn:=xlValues, after:=Range("A1"), lookat:=xlPart, MatchCase:=False)

If Not rng Is Nothing Then
ViewsRow = rng.Row

Else

MsgBox ("Cannot find No. of views")
Exit Sub
End If

.Range("A" & PublishedOnRow).Copy Destination:=ThisWorkbook.Sheets("Sheet1").Range("C1")
.Range("A" & ViewsRow).Copy Destination:=ThisWorkbook.Sheets("Sheet1").Range("B1")

End With

ThisWorkbook.Sheets("Sheet1").Range("B1") = Left(ThisWorkbook.Sheets("Sheet1").Range("B1"), InStr(ThisWorkbook.Sheets("Sheet1").Range("B1"), " views") - 1)
ThisWorkbook.Sheets("Sheet1").Range("C1") = Right(ThisWorkbook.Sheets("Sheet1").Range("C1"), Len(ThisWorkbook.Sheets("Sheet1").Range("C1")) - 13)
End Sub