Notes tests, Scrapping, YouTube

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

Page 14 https://excelfox.com/forum/showthrea...YouTube/page14
Post 131 #post19763 https://excelfox.com/forum/showthrea...ge14#post19763
https://excelfox.com/forum/showthrea...ll=1#post19763 ????

---

Kevin Stratvert DaVinci Resolve 18 - Full Tutorial for Beginners

Kevin Stratvert https://www.youtube.com/@KevinStratvert Learn Davinci Resolve/DaVinci Resolve 18 - Full Tutorial for Beginners https://www.youtube.com/watch?v=EEksPdEc7aI&authuser=0

Here the first link of a 6 video play list
https://www.youtube.com/watch?v=EEks...awizcm&index=1



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg. A0opm95t2XEA0q3KshmuuY
https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg
https://eileenslounge.com/viewtopic.php?p=318868#p318868
https://eileenslounge.com/viewtopic.php?p=318311#p318311
https://eileenslounge.com/viewtopic.php?p=318302#p318302
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317857#p317857
https://eileenslounge.com/viewtopic.php?p=317541#p317541
https://eileenslounge.com/viewtopic.php?p=317520#p317520
https://eileenslounge.com/viewtopic.php?p=317510#p317510
https://eileenslounge.com/viewtopic.php?p=317547#p317547
https://eileenslounge.com/viewtopic.php?p=317573#p317573
https://eileenslounge.com/viewtopic.php?p=317574#p317574
https://eileenslounge.com/viewtopic.php?p=317582#p317582
https://eileenslounge.com/viewtopic.php?p=317583#p317583
https://eileenslounge.com/viewtopic.php?p=317605#p317605
https://eileenslounge.com/viewtopic.php?p=316935#p316935
https://eileenslounge.com/viewtopic.php?p=317030#p317030
https://eileenslounge.com/viewtopic.php?p=317030#p317030
https://eileenslounge.com/viewtopic.php?p=317014#p317014
https://eileenslounge.com/viewtopic.php?p=316940#p316940
https://eileenslounge.com/viewtopic.php?p=316927#p316927
https://eileenslounge.com/viewtopic.php?p=316875#p316875
https://eileenslounge.com/viewtopic.php?p=316704#p316704
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316254#p316254
https://eileenslounge.com/viewtopic.php?p=316046#p316046
https://eileenslounge.com/viewtopic.php?p=317050&sid=d7e077e50e904a138c794e1 f2115da95#p317050
https://www.youtube.com/@alanelston2330
https://www.youtube.com/watch?v=yXaYszT11CA&lc=UgxEjo0Di9-9cnl8UnZ4AaABAg.9XYLEH1OwDIA35HNIei0z-
https://eileenslounge.com/viewtopic.php?p=316154#p316154
https://www.youtube.com/watch?v=TW3l7PkSPD4&lc=UgwAL_Jrv7yg7WWC8x14AaABAg
https://teylyn.com/2017/03/21/dollarsigns/#comment-191
https://eileenslounge.com/viewtopic.php?p=317050#p317050
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

---

We know what to do with that, just like all the other #xx2 posts in this Thread, using something like this…._

Code:

---

Option Explicit
Sub KevDevURLServerChromeLearnDavKev()  '    https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page12#post19743                  https://eileenslounge.com/viewtopic.php?p=303644#p303644  https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19741  https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing            https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA
 On Error GoTo Bed
'_1 First section get the long text string of the HTML coding of the internet Page
'_1(i) get the long single text string
'Dim strURLs As String: Let strURLs = "https://www.youtube.com/watch?v=Cy4_zrFja2w&list=UULFwInqvNXb-GN0JHdtoul_9A&index=1" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=d_RO2VIcFYw&list=UULFwInqvNXb-GN0JHdtoul_9A&index=76" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=gKNh43aEw_E&list=UULFwInqvNXb-GN0JHdtoul_9A&index=151" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=JzU7jFWbA6s&list=UULFwInqvNXb-GN0JHdtoul_9A&index=226" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=g_1_saf0E1I&list=UULFwInqvNXb-GN0JHdtoul_9A&index=301" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=IAIESH9vPbk&list=UULFwInqvNXb-GN0JHdtoul_9A&index=376" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=9u372_W07Nw&list=UULFwInqvNXb-GN0JHdtoul_9A&index=451" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=6SDkQ-iMrC4&list=UULFwInqvNXb-GN0JHdtoul_9A&index=526" & vbCr & vbLf & _
'"https://www.youtube.com/watch?v=EWr8G0r89k0&list=UULFwInqvNXb-GN0JHdtoul_9A&index=601"
'Dim URLs() As String: Let URLs() = Split(strURLs, vbCr & vbLf, 9, vbBinaryCompare)
'Dim Cnt As Long
'    For Cnt = LBound(URLs()) To UBound(URLs())
    Dim strURL As String, Indx As String
'    Let strURL = URLs(Cnt)
Let strURL = "https://www.youtube.com/watch?v=EEksPdEc7aI&list=PLlKpQrBME6xI-i6cL8Vdg2LOgjuawizcm&index=1"
Let Indx = Right(strURL, Len(strURL) - InStrRev(strURL, "&", -1, vbBinaryCompare))
Let Indx = Replace(Indx, "=", "_", 1, 1, vbBinaryCompare)
      With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", strURL, False ' '
        '.Open "GET", "", False ' '
        'No extra info here for type GET
        '.setRequestHeader bstrheader:="Ploppy", bstrvalue:="PooH" ' YOU MAY NEED TO TAKE OUT THIS LINE
                                                                                  '.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" '  https://www.autohotkey.com/boards/viewtopic.php?t=9554  ---  It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
        .setRequestHeader "User-Agent", "Chrome"  '  https://eileenslounge.com/viewtopic.php?p=303639#p303639
        .send ' varBody:= ' No extra info for type GET. .send actually makes the request
          While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
      Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc.    The responseText property returns the information requested by the Open method as a text string
      End With
  '_1(ii)  Optional secion  to put the text string into a text file , for ease of code developments
  Dim FileNum2 As Long: Let FileNum2 = FreeFile(0)                                  ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
  Dim PathAndFileName2 As String
    Let PathAndFileName2 = ThisWorkbook.Path & "\" & "\KevDev\" & "KevDevServerChrome" & Indx & ".txt" ' "WieGehtsYouTubeServerChrome526" & ".txt" ' "WieGehtsYouTubeServerChrome451" & ".txt" '  "WieGehtsYouTubeServerChrome376" & ".txt" '  "WieGehtsYouTubeServerChrome301" & ".txt" '  "WieGehtsYouTubeServerChrome226" & ".txt" '  "WieGehtsYouTubeServerChrome151" & ".txt" '  "WieGehtsYouTubeServerChrome76" & ".txt"  '  "WieGehtsYouTubeServerChrome1" & ".txt"  '
  Open PathAndFileName2 For Output As #FileNum2 ' ' The text file will be made if not there, and if it is there and already contains data, then the data will be overwritten
    Print #FileNum2, PageSrc '
    Close #FileNum2
'    Next Cnt
Exit Sub  '  Normal code error in the case of no errors
Bed:
 MsgBox Prompt:=Err.Number & ":  " & Err.Description: Debug.Print Err.Number & ":  " & Err.Description
End Sub  ' Code end in the case of any error

---

_... to get this: https://i.postimg.cc/ZWj46Rnc/Kev-Dev-txt.jpg

#133 #post19765 https://excelfox.com/forum/showthrea...ge14#post19765

---

just like all the other #xx3 posts in this Thread, using something like this…._

Code:

---


Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_DavKev()  '  look for this - hqdefault.jpg
Rem 0a
Dim WsDK As Worksheet:  Set WsDK = ThisWorkbook.Worksheets.Item("LearnDavKev")
'Rem 0b) An Array of all the 9 text files got from the last macro  Sub WieGehtsYouTubeURLServerChromeHybridStep75_2()
'Dim strTxts As String: Let strTxts = "WieGehtsYouTubePopularServerChromeindex_1.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_76.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_151.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_226.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_301.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_376.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_451.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_526.txt" & vbCr & vbLf & _
'"WieGehtsYouTubePopularServerChromeindex_601.txt"
'Dim Txts() As String: Let Txts() = Split(strTxts, vbCr & vbLf, 9, vbBinaryCompare)
   
'Dim Cnt As Long
'    For Cnt = LBound(Txts()) To UBound(Txts())    ' Loop all the text files got from the last macro  Sub WieGehtsYouTubeURLServerChromeHybridStep75_2() ==
    ' Rem 1 Get the text files as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1)                                    ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
 '                                            Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "WieGehtsYouTubeServerChrome.txt"  '
' Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "GettingStarted\" & Txts(Cnt)  ' "WieGehtsYouTubeServerChrome601.txt" ' "WieGehtsYouTubeServerChrome526.txt" ' "WieGehtsYouTubeServerChrome451.txt" ' "WieGehtsYouTubeServerChrome376.txt" ' "WieGehtsYouTubeServerChrome301.txt" ' "WieGehtsYouTubeServerChrome226.txt" ' "WieGehtsYouTubeServerChrome151.txt" '  "WieGehtsYouTubeServerChrome76.txt" '  '"WieGehtsYouTubeServerChrome1.txt"  '
 Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "KevDev\" & "KevDevServerChromeindex_1.txt"                                          ' "WieGehtsYouTubeServerChrome601.txt" ' "WieGehtsYouTubeServerChrome526.txt" ' "WieGehtsYouTubeServerChrome451.txt" ' "WieGehtsYouTubeServerChrome376.txt" ' "WieGehtsYouTubeServerChrome301.txt" ' "WieGehtsYouTubeServerChrome226.txt" ' "WieGehtsYouTubeServerChrome151.txt" '  "WieGehtsYouTubeServerChrome76.txt" '  '"WieGehtsYouTubeServerChrome1.txt"  '
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
' Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
'Get #FileNum, , TotalFile
'  Or  http://www.eileenslounge.com/viewtopic.php?p=295782&sid=f6dcab07c4d24e00e697fe4343dc7392#p295782
 Let TotalFile = Input(LOF(FileNum), FileNum)
Close #FileNum
' Rem 2 Get all links based on the unique bit of index=x, where x is 1 2 3 4 ...... etc
'                  Dim Cnt As Long: Let Cnt = 1
Dim TextBit As String: Let TextBit = TotalFile
Dim posJpg As Long: Let posJpg = InStr(1, TextBit, "hqdefault.jpg", vbBinaryCompare)
    Do While posJpg <> 0
    Dim strURL As String: Let strURL = Mid(TextBit, posJpg - 12, 11)
    Dim Unics As String  '  This is mainly because sometimes the same 11 digit bit  appears a few times in a text file,    But Note that because I dont initialise / reset this then, unlike the previous code done once for each text file,  I will also catch the duplicates caused by me overlapping the URLs that I used, like , example at the start of the second main outer loop, the 76th 77th 78th and 79th would not get added
        If InStr(1, Unics, strURL, vbBinaryCompare) = 0 Then
        Let Unics = Unics & " " & strURL
        Dim Lr1 As Long: Let Lr1 = WsDK.Range("A" & WsDK.Rows.Count & "").End(xlUp).Row
        Dim Nr As Long
            If WsDK.Range("A1").Value = "" Then
            Let Nr = 1
            Else
            Let Nr = Lr1 + 1
            End If
        Let WsDK.Range("A" & Nr & "").Value = strURL
           
        Else ' Got a dup
'            Let WsPop.Range("C" & Nr & "").Value = WsPop.Range("C" & Nr & "").Value + 1 ' for count of dups
        End If
    Let TextBit = Mid(TextBit, posJpg + 1)
    Let posJpg = InStr(1, TextBit, "hqdefault.jpg", vbBinaryCompare)
    Loop
'    Next Cnt  '  ============================
WsDK.Columns(1).AutoFit
End Sub

---

_... give something like this https://i.postimg.cc/TyS2tMHF/Kev-De...-Play-List.jpg

Note: quite a few more ( 26 ) than the 6 of the Play List

#134 #post19766 https://excelfox.com/forum/showthrea...ge14#post19766

---

To bring us to the level of the last few attempts, at the #xx4th post, here is the macro




To bring us to the level of the last few attempts, at the #xx4th post, here is the macro

Code:

---

Sub GetStuffFrom11DigitYouTubeKevDav()  '    https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page14#post19766
Rem 0 Worksheets info
Dim WsKD As Worksheet: Set WsKD = ThisWorkbook.Worksheets("LearnDavKev")
Dim RngWsYT11 As Range: Set RngWsYT11 = WsKD.Range("A1:A27")    '  36")  '  680") ' 692")
Dim Cnt As Long
WsKD.Activate
ActiveWindow.Panes(3).Activate ' To get out of top pane and into bottom pane (I have worksheet divided at line 1)  This is so only the bottom pane is scrolled and the first line in pane 1 with the headings in stays there
Rem 1 The main stuff now - take every 11 digit bit , make a full link of it, scrape all the text and do all the business
    For Cnt = 2 To 27 ' 680 '  692
    RngWsYT11.Item(Cnt).Select
        '                  If RngWsYT11.Item(Cnt).Offset(0, 1).Value2 <> "" Then
        If RngWsYT11.Item(Cnt).Value2 <> "" Then
            With CreateObject("MSXML2.ServerXMLHTTP")  '  .Server - Yasser http://www.eileenslounge.com/viewtopic.php?p=303638#p303638
            .Open "GET", "https://www.youtube.com/watch?v=" & RngWsYT11.Item(Cnt).Value2, False ' '
            .setRequestHeader "User-Agent", "Chrome"  ' - SpeakEasy Mike  https://eileenslounge.com/viewtopic.php?p=303639#p303639
            .send ' varBody:= ' No extra info for type GET. .send actually makes the request
                While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
            Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc.    The responseText property returns the information requested by the Open method as a text string
            End With
            '_1(ii)  Optional secion  to put the text string into a text file , for ease of code developments and debugging
        Dim FileNum2 As Long: Let FileNum2 = FreeFile(0)                                  ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
        Dim PathAndFileName2 As String
        Let PathAndFileName2 = ThisWorkbook.Path & "\KevDev\KevDevServerChrome" & RngWsYT11.Item(Cnt).Value2 & ".txt" '
        Open PathAndFileName2 For Output As #FileNum2 ' ' The text file will be made if not there, and if it is there and already contains data, then the data will be overwritten
        Print #FileNum2, PageSrc '
        Close #FileNum2
   
    ' If RngWsYT11.Item(Cnt).Offset(0, 1).Value2 = "GWGzz5p5D80" Then Stop In case I want to stop at a particular 11 digit bit for debugging
        Dim TextBit As String ' The idea is to get a chunk of text that seems to have all the info I want
        Let TextBit = Split(PageSrc, "videoDescriptionHeaderRenderer""", 2, vbBinaryCompare)(1)
        'Let TextBit = Mid(TextBit, 1, 600)
        Let TextBit = Mid(TextBit, 1, 1400)
       
        Dim Title As String
    '        Let Title = Split(TextBit, ":{""title"":{""runs"":[{""text"":""", 2, vbBinaryCompare)(1)
    '        'Let Title = Split(Title, """}]},""channel""", 2, vbBinaryCompare)(0)
    '        Let Title = Split(Title, """}", 2, vbBinaryCompare)(0)
    '            If InStr(1, TextBit, """,""navigationEndpoint""", vbBinaryCompare) <> 0 Then
    '            Let Title = Split(TextBit, ":{""title"":{""runs"":[{""text"":""", 2, vbBinaryCompare)(1)
    '            Dim Pos1nav As Long, Pos2nav As Long
    '            Let Pos1nav = InStr(1, Title, """,""navigationEndpoint""", vbBinaryCompare)
    '            Let Pos2nav = InStr(Pos1nav, Title, "{""text"":""", vbBinaryCompare)
    '            Let Title = Left(Title, Pos1nav - 1) & Right(Title, Len(Title) - (Pos2nav + 8))
    '            Let Title = Split(Title, """}", 2, vbBinaryCompare)(0)
    '            Else
    '            End If
    '  That above checked for link text crap, but only worked if the link was at the beginning of the title: If the link was inside it or at the end, we will end up with multiple text bits, (and the link text crap)  I need to join together and ignore link text crap  -  BTW "link text crap" is what comes after the text seen for the link which is needed to make it work, but i don't want it        .... Text1 .. Textseenforlink .. textcrapneededtomakelinkwork  ... Text3    etc
        Dim posTxtTag As Long ' Usually there will be just one bit of  {"text":"    after which come the title, but sometimes there may be a few as in the case of a link in the title..
        Let posTxtTag = InStr(1, TextBit, "{""text"":""", vbBinaryCompare)
            Do While posTxtTag <> 0 And posTxtTag < InStr(1, TextBit, """channel""", vbBinaryCompare) ' hopefully the text    channel  always comes after the title and before anything else I want
            Dim posTxtTagEnd As Long, posTxtTagEnd2 As Long
            Let posTxtTagEnd = InStr(posTxtTag, TextBit, """,""navigationEndpoint", vbBinaryCompare)  ' This gives me the end of the text for the case of a link text
                If posTxtTagEnd = 0 Then Let posTxtTagEnd = 999 ' If I ain't got a link then I make this big so it does not get used
            Let posTxtTagEnd2 = InStr(posTxtTag, TextBit, """}", vbBinaryCompare)  ' mostly this would be the end of a text bit
            Let posTxtTagEnd = Application.WorksheetFunction.Min(posTxtTagEnd, posTxtTagEnd2) ' Whatever text end I have or watever text end comes first will be used
            Let Title = Title & Mid(TextBit, posTxtTag + 9, (posTxtTagEnd - (posTxtTag + 9))) ' mostly this would only be done once, just more times for building the text if its split into bits by the use of a link in the title
            Let posTxtTag = InStr(posTxtTagEnd, TextBit, "{""text"":""", vbBinaryCompare) ' This will mostly be 0, unless text is split into bits by the use of a link in the title
            Loop ' While posTxtTag <> 0
        ' some initially empirically found Title tidying up
          Let Title = Replace(Title, "\u0026", "&", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "\""", " ", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "/", " ", 1, -1, vbBinaryCompare)
          Let RngWsYT11.Item(Cnt).Offset(0, 9).Value = Title
        ' Do some empirical text tidying up that I might typically have done in a final video title
         
          Let Title = Replace(Title, "ä", "ae", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "ü", "ue", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "ö", "oe", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "Ä", "AE", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "Ü", "UE", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "Ö", "OE", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "-", " ", 1, -1, vbBinaryCompare) ' Important to do this - if in doubt change to a space as otherwise words may get joiuned ( More than one space are easilly removed after )
          Let Title = Replace(Title, "#wiegehtyoutube", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "!", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "?", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "ß", "ss", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "€", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, ":", " ", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "#", " ", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "&", " ", 1, -1, vbBinaryCompare) '
          Let Title = Replace(Title, "'", " ", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "‚", " ", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, """", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "“", " ", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "„", " ", 1, -1, vbBinaryCompare)  '    „ajdffak“
          Let Title = Replace(Title, "+", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, ".", "", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "YouTube", "UT", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "[", "(", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "]", ")", 1, -1, vbBinaryCompare)
          Let Title = Replace(Title, "|", " ", 1, -1, vbBinaryCompare)
    '    Let Title = Replace(Title, "-", " ", 1, -1, vbBinaryCompare)
    '    Let Title = Replace(Title, "-", " ", 1, -1, vbBinaryCompare)
    '    Let Title = Replace(Title, "-", " ", 1, -1, vbBinaryCompare)
    '    Let Title = Replace(Title, "-", " ", 1, -1, vbBinaryCompare)
          Let Title = Application.WorksheetFunction.Trim(Title) ' In case any spaces caused by removing stuff
   
        Let RngWsYT11.Item(Cnt).Offset(0, 2).Value2 = Title
        Let Title = "" ' If i don't do this the  Title = Title &  coding will keep adding the titles together
        RngWsYT11.Item(Cnt).Offset(0, 2).Select ' This is helpful or else I cant see the worksheet being filled after the first few
        ' To get the next info i use a lot the  Split Split  bit Yasser showed me  https://eileenslounge.com/viewtopic.php?p=303638#p303638
        Dim Views As String
        Let Views = Split(TextBit, """},""views"":{""simpleText"":""", 2, vbBinaryCompare)(1)
        Let Views = Split(Views, " Aufrufe""}", 2, vbBinaryCompare)(0)
        Let Views = Replace(Views, ".", "", 1, -1, vbBinaryCompare) ' I don't like seperators of any kind
        Let RngWsYT11.Item(Cnt).Offset(0, 4).Value2 = Views
        Dim PubDate As String
        Let PubDate = Split(TextBit, "publishDate"":{""simpleText"":""", 2, vbBinaryCompare)(1)
        Let PubDate = Split(PubDate, """},""factoid"":[{", 2, vbBinaryCompare)(0)
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value2 = PubDate
        ' date nightmares again
        Dim PubDateV2 As Long, Naw As Long ' DateSerial(year, month, day)
        Dim PubDateRaw As String: Let PubDateRaw = Replace(PubDate, "Premiere am ", "", 1, 1, vbBinaryCompare)
        Let PubDateRaw = Replace(PubDateRaw, "Live übertragen am ", "", 1, 1, vbBinaryCompare)
        Let PubDateV2 = DateSerial(Right(PubDateRaw, 4), Mid(PubDateRaw, 4, 2), Left(PubDateRaw, 2))
        Let RngWsYT11.Item(Cnt).Offset(0, 1).Value2 = PubDateV2
        Let Naw = Evaluate("=NOW()"): ' Debug.Print Naw
    '        Debug.Print Format(PubDateV2, "\Da\y i\s " & "dddd")
    '        Debug.Print Format(PubDateV2, "dddd DD mmm YYYY") & " " & Format(Naw, "dddd DD mmm YYYY")
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value2 = PubDateV2
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value = PubDate
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value = Format(PubDateV2, "dddd DD mmm YYYY")
        Let RngWsYT11.Item(Cnt).Offset(0, 5).Value = Int(Views / (Naw - PubDateV2))
        Dim Likeses As String
        Let Likeses = Split(TextBit, "Mag ich\""-Bewertungen""},""accessibilityText"":""", 2, vbBinaryCompare)(1)
        Let Likeses = Split(Likeses, " \""Mag ich\""-Bewertungen", 2, vbBinaryCompare)(0)
            If InStr(1, Likeses, "Keine", vbBinaryCompare) = 0 Then ' Sometimes the likes are not there  or not showmn or something - only happend in a video not from the main author
            'Let RngWsYT11.Item(Cnt).Offset(0, 6).Value = Likeses
            Let RngWsYT11.Item(Cnt).Offset(0, 7).Value = Int(Likeses / (Naw - PubDateV2))
            Else
            Let Likeses = "Keine"
            End If
        Let RngWsYT11.Item(Cnt).Offset(0, 6).Value = Likeses
        RngWsYT11.Parent.Columns("A:H").AutoFit
        Else
        End If
    Next Cnt
End Sub

---

Here is a wod

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

---

Some note in support of this main forum post
https://eileenslounge.com/viewtopic....303644#p303644

---

<lkhdksljd

This is post https://excelfox.com/forum/showthrea...ll=1#post19610
#post19610
It was copied initially before I edited it from the post above, #post16727 , and that #post16727 stayes yellow highlighted after the copy

---

Some note in support of this main forum post
https://eileenslounge.com/viewtopic....303644#p303644
https://eileenslounge.com/viewtopic....303704#p303704

„WieGehtsYouTubeServerChrome.txt“ https://app.box.com/s/a7k2izgyzqhd7f98hlaq9csw0l4tyyl6

---

First main working coding attempt, explanation in 'comments and last post

Code:

---


Sub GetStuffFrom11DigitYouTube()
Rem 0 Worksheets info
Dim WsYT11 As Worksheet: Set WsYT11 = ThisWorkbook.Worksheets("ElevenDigitYT")
Dim RngWsYT11 As Range: Set RngWsYT11 = WsYT11.Range("A1:A1008")
Dim Unics As String
Dim Cnt As Long
    For Cnt = 2 To 1009
        If InStr(1, Unics, RngWsYT11.Item(Cnt).Value2, vbBinaryCompare) = 0 Then ' Check to see if I not got this the 11 digit bit yet .....  but there may be duplicates for the list from each text file as I click a bit above the last link, say on 76th link ,rather than the typical last 79th link, ( if I clicked on the 79th link I would get the unique 11 digit bit for the 79th video twice from the first two text files, by clicking on the 76th link I will get in both the first two text files the 11 digit bit for the 76th 77th 78th and 79th )
        Let RngWsYT11.Item(Cnt).Offset(0, 1).Value2 = RngWsYT11.Item(Cnt).Value2 ' Puts the 11 digit bit in column B if i have not had that 11 digit bit yet
        Let Unics = Unics & RngWsYT11.Item(Cnt).Value2 & " " ' Put the 11 digit bit in a string which i check to see if i got this one already
        Else
        ' already got this 11 digit bit, so leave the row empty
        End If
    Next Cnt
Rem 1 The main stuff now - take every 11 digit bit , make a full link of it, scrape all the text and do all the business
    For Cnt = 2 To 1009
        If RngWsYT11.Item(Cnt).Offset(0, 1).Value2 <> "" Then
            With CreateObject("MSXML2.ServerXMLHTTP")
            .Open "GET", "https://www.youtube.com/watch?v=" & RngWsYT11.Item(Cnt).Offset(0, 1).Value2, False ' '
            .setRequestHeader "User-Agent", "Chrome"  '  https://eileenslounge.com/viewtopic.php?p=303639#p303639
            .send ' varBody:= ' No extra info for type GET. .send actually makes the request
                While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
            Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc.    The responseText property returns the information requested by the Open method as a text string
            End With
            '_1(ii)  Optional secion  to put the text string into a text file , for ease of code developments and debugging
        Dim FileNum2 As Long: Let FileNum2 = FreeFile(0)                                  ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
        Dim PathAndFileName2 As String
        Let PathAndFileName2 = ThisWorkbook.Path & "\" & "WieGehtsYouTubeServerChrome" & RngWsYT11.Item(Cnt).Offset(0, 1).Value2 & ".txt" ' "WieGehtsYouTubeServerChrome526" & ".txt" ' "WieGehtsYouTubeServerChrome451" & ".txt" '  "WieGehtsYouTubeServerChrome376" & ".txt" '  "WieGehtsYouTubeServerChrome301" & ".txt" '  "WieGehtsYouTubeServerChrome226" & ".txt" '  "WieGehtsYouTubeServerChrome151" & ".txt" '  "WieGehtsYouTubeServerChrome76" & ".txt"  '  "WieGehtsYouTubeServerChrome1" & ".txt"  '
        Open PathAndFileName2 For Output As #FileNum2 ' ' The text file will be made if not there, and if it is there and already contains data, then the data will be overwritten
        Print #FileNum2, PageSrc '
        Close #FileNum2
 
' If RngWsYT11.Item(Cnt).Offset(0, 1).Value2 = "GWGzz5p5D80" Then Stop In case I want to stop at a particular 11 digit bit for debugging
        Dim TextBit As String ' The idea is to get a chunk of text that seems to have all the info I want
        Let TextBit = Split(PageSrc, "videoDescriptionHeaderRenderer""", 2, vbBinaryCompare)(1)
        'Let TextBit = Mid(TextBit, 1, 600)
        Let TextBit = Mid(TextBit, 1, 1400)
       
        Dim Title As String
'        Let Title = Split(TextBit, ":{""title"":{""runs"":[{""text"":""", 2, vbBinaryCompare)(1)
'        'Let Title = Split(Title, """}]},""channel""", 2, vbBinaryCompare)(0)
'        Let Title = Split(Title, """}", 2, vbBinaryCompare)(0)
'            If InStr(1, TextBit, """,""navigationEndpoint""", vbBinaryCompare) <> 0 Then
'            Let Title = Split(TextBit, ":{""title"":{""runs"":[{""text"":""", 2, vbBinaryCompare)(1)
'            Dim Pos1nav As Long, Pos2nav As Long
'            Let Pos1nav = InStr(1, Title, """,""navigationEndpoint""", vbBinaryCompare)
'            Let Pos2nav = InStr(Pos1nav, Title, "{""text"":""", vbBinaryCompare)
'            Let Title = Left(Title, Pos1nav - 1) & Right(Title, Len(Title) - (Pos2nav + 8))
'            Let Title = Split(Title, """}", 2, vbBinaryCompare)(0)
'            Else
'            End If
'  That above checked for link text crap, but only worked if the link was at the beginning of the title: If the link was inside it or at the end, we will end up with multiple text bits, (and the link text crap)  I need to join together and ignore link text crap  -  BTW "link text crap" is what comes after the text seen for the link which is needed to make it work, but i don't want it        .... Text1 .. Textseenforlink .. textcrapneededtomakelinkwork  ... Text3    etc
        Dim posTxtTag As Long ' Usually there will be just one bit of  {"text":"    after which come the title, but sometimes there may be a few as in the case of a link in the title..
        Let posTxtTag = InStr(1, TextBit, "{""text"":""", vbBinaryCompare)
            Do While posTxtTag <> 0 And posTxtTag < InStr(1, TextBit, """channel""", vbBinaryCompare) ' hopefully the text    channel  always comes after the title and before anything else I want
            Dim posTxtTagEnd As Long, posTxtTagEnd2 As Long
            Let posTxtTagEnd = InStr(posTxtTag, TextBit, """,""navigationEndpoint", vbBinaryCompare)  ' This gives me the end of the text for the case of a link text
                If posTxtTagEnd = 0 Then Let posTxtTagEnd = 999 ' If I ain't got a link then I make this big so it does not get used
            Let posTxtTagEnd2 = InStr(posTxtTag, TextBit, """}", vbBinaryCompare)  ' mostly this would be the end of a text bit
            Let posTxtTagEnd = Application.WorksheetFunction.Min(posTxtTagEnd, posTxtTagEnd2) ' Whatever text end I have or watever text end comes first will be used
            Let Title = Title & Mid(TextBit, posTxtTag + 9, (posTxtTagEnd - (posTxtTag + 9))) ' mostly this would only be done once, just more times for building the text if its split into bits by the use of a link in the title
            Let posTxtTag = InStr(posTxtTagEnd, TextBit, "{""text"":""", vbBinaryCompare) ' This will mostly be 0, unless text is split into bits by the use of a link in the title
            Loop ' While posTxtTag <> 0
        Let RngWsYT11.Item(Cnt).Offset(0, 2).Value2 = Title
        Let Title = "" ' If i don't do this the  Title = Title &  coding will keep adding the titles together
        RngWsYT11.Item(Cnt).Offset(0, 2).Select ' This is helpful or else I cant see the worksheet being filled after the first few
        ' To get the next info i use a lot the  Split Split  bit Yasser showed me  https://eileenslounge.com/viewtopic.php?p=303638#p303638
        Dim Views As String
        Let Views = Split(TextBit, """},""views"":{""simpleText"":""", 2, vbBinaryCompare)(1)
        Let Views = Split(Views, " Aufrufe""}", 2, vbBinaryCompare)(0)
        Let Views = Replace(Views, ".", "", 1, -1, vbBinaryCompare) ' I don't like seperators of any kind
        Let RngWsYT11.Item(Cnt).Offset(0, 4).Value2 = Views
        Dim PubDate As String
        Let PubDate = Split(TextBit, "publishDate"":{""simpleText"":""", 2, vbBinaryCompare)(1)
        Let PubDate = Split(PubDate, """},""factoid"":[{", 2, vbBinaryCompare)(0)
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value2 = PubDate
        ' date nightmares again
        Dim PubDateV2 As Long, Naw As Long ' DateSerial(year, month, day)
        Dim PubDateRaw As String: Let PubDateRaw = Replace(PubDate, "Premiere am ", "", 1, 1, vbBinaryCompare)
        Let PubDateV2 = DateSerial(Right(PubDateRaw, 4), Mid(PubDateRaw, 4, 2), Left(PubDateRaw, 2))
        Let Naw = Evaluate("=NOW()"): ' Debug.Print Naw
'        Debug.Print Format(PubDateV2, "\Da\y i\s " & "dddd")
'        Debug.Print Format(PubDateV2, "dddd DD mmm YYYY") & " " & Format(Naw, "dddd DD mmm YYYY")
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value2 = PubDateV2
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value = PubDate
        Let RngWsYT11.Item(Cnt).Offset(0, 3).Value = Format(PubDateV2, "dddd DD mmm YYYY")
        Let RngWsYT11.Item(Cnt).Offset(0, 5).Value = Int(Views / (Naw - PubDateV2))
        Dim Likeses As String
        Let Likeses = Split(TextBit, "Mag ich\""-Bewertungen""},""accessibilityText"":""", 2, vbBinaryCompare)(1)
        Let Likeses = Split(Likeses, " \""Mag ich\""-Bewertungen", 2, vbBinaryCompare)(0)
            If InStr(1, Likeses, "Keine", vbBinaryCompare) = 0 Then ' Sometimes the likes are not there  or not showmn or something - only happend in a video not from the main author
            'Let RngWsYT11.Item(Cnt).Offset(0, 6).Value = Likeses
            Let RngWsYT11.Item(Cnt).Offset(0, 7).Value = Int(Likeses / (Naw - PubDateV2))
            Else
            Let Likeses = "Keine"
            End If
        Let RngWsYT11.Item(Cnt).Offset(0, 6).Value = Likeses
        RngWsYT11.Parent.Columns("A:H").AutoFit
        Else
        End If
    Next Cnt
End Sub

---

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

ljdcsljd

AKJDakjdha

---

Some note in support of this main forum post
https://eileenslounge.com/viewtopic....303644#p303644

---

<lkhdksljd