-
Post 111 #post19743 https://excelfox.com/forum/showthrea...ge12#post19743
The Getting Started list
There are not many videos in this list, so I could try a scrap based on the Play all link, but first for consistency I will try the corresponding way I did before, but this time I will just have to get 1 text file from 1 link, ( The first one in the play list ), rather than the 9 necessary on the previous longer play list.
So this is the navigation to go through to get that link
_ First the YouTube channel, So geht YouTube https://www.youtube.com/@SogehtYouTube
_ Then at the play list, Die ersten Schritte auf YouTube , be careful, as you don’t want the link behind Die ersten Schritte auf YouTube , ( https://www.youtube.com/playlist?lis...12COqru03rchWt
), but rather the one to the right of that is which you should click, which is in behind Play all , This is the one -
https://www.youtube.com/watch?v=nlZd...12COqru03rchWt
_ Then get the final required link from the one behind the first video in the small vertically scrollable window on the right
https://www.youtube.com/watch?v=nlZd...3rchWt&index=1
https://www.youtube.com/watch?v=nlZdIkipTIY&list=PLipJz-fzcvQWvyJavhI12COqru03rchWt&index=1
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.eileenslounge.com/viewtopic.php?p=296754#p296754
https://www.eileenslounge.com/viewtopic.php?p=296859#p296859
https://teylyn.com/2017/03/21/dollarsigns/#comment-191
https://www.excelfox.com/forum/showthread.php/2918-Right-Hand-Side-Range-Range-Value-values-Range-Range-Value-only-sometimes-Range-Range-Value-Anomaly
https://www.excelfox.com/forum/showthread.php/2355-Tests-and-Notes-on-Range-Referrencing/page8
https://www.eileenslounge.com/viewtopic.php?p=296859#p296859
https://www.excelfox.com/forum/showthread.php/2355-Tests-and-Notes-on-Range-Referrencing?p=24006&viewfull=1#post24006
https://www.excelfox.com/forum/showthread.php/2909-Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=23185&viewfull=1#post23185
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
-
Coding follows along from before, ( https://excelfox.com/forum/showthrea...ge11#post19741 ) .
The only difference is that I can avoid looping the links as I only have one, and the folder for things in this attempt will be
GettingStarted
Here is the final text file, …_https://i.postimg.cc/4nFVS37L/Text-F...irst-Video.jpg ,
___________________________________.... It was got from this macro
Code:
Option Explicit
Sub WieGehtsYouTubeURLServerChromeGettingStarted() ' 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=nlZdIkipTIY&list=PLipJz-fzcvQWvyJavhI12COqru03rchWt&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 & "\" & "GettingStarted\" & "WieGehtsYouTubePopularServerChrome" & 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
-
Post 113 #post19745 https://excelfox.com/forum/showthrea...ge12#post19745
Next is as usual to pull out the 11 digit YouTube bit of a typical YouTube video, so same code as before, ( https://excelfox.com/forum/showthrea...ge11#post19742 ) , but without the looping, and folder to find the single text file worksheet changed to GettingStarted and the worksheet for the results also I have named GettingStarted
Code:
Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_ErstenShitPlayList() ' look for this - hqdefault.jpg
Rem 0a
Dim WsGS As Worksheet: Set WsGS = ThisWorkbook.Worksheets.Item("GettingStarted")
'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 & "GettingStarted\" & "WieGehtsYouTubePopularServerChromeindex_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 = WsGS.Range("A" & WsGS.Rows.Count & "").End(xlUp).Row
Dim Nr As Long
If WsGS.Range("A1").Value = "" Then
Let Nr = 1
Else
Let Nr = Lr1 + 1
End If
Let WsGS.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 ' ============================
WsGS.Columns(1).AutoFit
End Sub
'_-_____________________________________________________________________________________________________
https://i.postimg.cc/KRSSdjvG/11-Digit-You-Tube-Bit.jpg
-
' https://excelfox.com/forum/showthrea...ge12#post19746
To bring us to the level of the last few attempts, we have the main macro. This has had a few minor tweaks. Mostly these are involved with Title given out, which has always been a bit modified. I will take this a bit further for fun and give a version un modified in column J, and then perhaps do some other experimenting
Code:
' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page12#post19746
Sub GetStuffFrom11DigitYouTubegettingStarted() ' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19733
Rem 0 Worksheets info
Dim WsYT11 As Worksheet: Set WsYT11 = ThisWorkbook.Worksheets("GettingStarted")
Dim RngWsYT11 As Range: Set RngWsYT11 = WsYT11.Range("A1:A36") ' 680") ' 692")
Dim Cnt As Long
WsYT11.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 36 ' 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 & "\GettingStarted\WieGehtsYouTubeServerChrome" & 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
I note I had 2 strange rogue 11 digit bits….
JtF7ezbMY%2
hvItQ2jTM%2
So for now I will just remove those.
https://i.postimg.cc/7J4VKmb8/Getting-Started.jpg https://i.postimg.cc/T1L4Ys6w/Getting-Started.jpg
-
Here is the usual wad of coding to get us a final ordered ( included V2 date ) set of titled files, for this getting Started case
Code:
'
Sub QwickDuh()
Rem 0a
Dim WsGS As Worksheet: Set WsGS = ThisWorkbook.Worksheets.Item("GettingStarted")
Rem 1
Dim DaDuh As String
Let DaDuh = Dir(PathName:=ThisWorkbook.Path & "\GettingStarted\" & "*.wmv", Attributes:=vbNormal)
Dim Rw As Long: Let Rw = 1
Do While DaDuh <> ""
Let Rw = Rw + 1
Let WsGS.Range("K" & Rw & "").Value = DaDuh
Let DaDuh = Dir
Loop ' While dahuh <> ""
End Sub
Sub TestingTitlSrch()
Rem 0a
Dim WsGS As Worksheet: Set WsGS = Me
Dim RngSrch As Range: Set RngSrch = WsGS.Range("C2:C34")
Dim RngK As Range: Set RngK = WsGS.Range("K2:K32")
Dim Knt As Long, aCel As Range
For Knt = 2 To 32
Set aCel = TitlSrch(RngK.Item(Knt - 1).Value, RngSrch)
If Not aCel Is Nothing Then
Debug.Print "Found at row " & aCel.Row & " """ & aCel.Value & """"
'Rng.Parent.Activate
Let Application.EnableEvents = False
aCel.Select
RngK.Item(Knt - 1).Select
Let Application.EnableEvents = True
'Let RngK.Item(Knt - 1).Offset(0, 1).Value2 = aCel.Offset(0, -1).Value2 ' Date in V2
Let RngK.Item(Knt - 1).Offset(0, 1).Value2 = aCel.Offset(0, -1).Value2 & " " & aCel.Value ' Date in V2 and space and main scraped(modified) title value
'Let RngK.Item(Knt - 1).Offset(0, 2).Value2 = aCel.Offset.Value2
Else
Debug.Print "Cant't find " & RngK.Item(Knt - 1).Value
End If
Next Knt
End Sub
' This function is a VBA array looping thing. It tidies up a bit a string Title you give it in the typical way i might tidy up a title. Then it splits that by spaces, and tries to match a lot of words from that in a Title in the given range of Titles. It reduces the amount of words it tries to match until it finds a match or gives up and tells you it never managed it
' The basic idea is to split the Title to be looked for by a space so we have a one dimensional array of all the words in that title, and then we try to find a title in the list to be searched that has at least a certain number , HitsWish , of those words. That number is determined empirically , and if that amount of number is not found we keep reducing the HitsWish. So we do our best to match as many words as possible. That way we improve the chances of matching the right one
' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19705
'Public Function TitlSrch(TrgtVal As String, SrchClm As Range) As Range
'(TrgtVal is range selected value, SrchClm is LookUpTable) The return is the found cell range
'Typically the Dir given title, Typically the main scraped Titles range The returned range is the cell in the main scraped list of the matched title, so that we can Offset from that to get the other info we want such as date V2
Sub CopyChangeNameToAddDateAnd11DigitBitFSO() ' Scripting.FileSystemObject
Rem 0
Dim WsGS As Worksheet: Set WsGS = Me
Dim Parf As String, Parf2 As String
Dim FSOLibrary As Object, FSOFolder As Object, FSOFile As Object
'Set the file name to a variable
Let Parf = ThisWorkbook.Path & "\GettingStarted\"
Let Parf2 = ThisWorkbook.Path & "\GettingStarted\GettingStartedWMV\"
Set FSOLibrary = CreateObject(Class:="Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.GetFolder(Parf)
'Use For Each loop to loop through each file in the folder
Dim Rw As Long: Let Rw = 1 ' So as to start at 2 by a Rw = Rw + 1 in a loop
For Each FSOFile In FSOFolder.Files
If Right(FSOFile.Name, 4) = ".wmv" Then
Let Rw = Rw + 1
'Let WsGS.Range("N" & Rw & "").Value = FSOFile.Name ' for quick check before rename
FSOFile.Copy (Parf2 & WsGS.Range("L" & Rw & "").Value2 & ".wmv")
'FSOFile.Copy (Parf2 & Format(Rw, "000") & " " & Wsmp4WMV.Range("G" & Rw & "").Value2)
'FSOFile.Copy (Parf2 & Format(1, "000") & " " & Wsmp4WMV.Range("G" & Rw & "").Value2)
Else
End If
Next
'Release the memory
Set FSOLibrary = Nothing
Set FSOFolder = Nothing
End Sub
-
-
-
-
-
