Notes tests, Scrapping, YouTube [Archive] - Excel, Access, PowerPoint and Word VBA Macro Automation Help

DocAElstein

06-16-2020, 11:14 AM

One important note at the outset of these notes is that my Excel is default German. I expect therefore issues likely to arise in anything to do with use of a comma , because often the comma , in English for certain things in Excel is replaced with the semi colon ; in German Excel.

Wot’s in a .csv file
In many Excel versions, you have the choice of three different Save As options related to .csv extension files https://excel.tips.net/T002519_Comma-Delimited_Differences_for_PC_and_Mac.html

So lets have a quick look at what the differences are…
In each of the 3 cases I will
make a virgin default template, save it
make a virgin default template, put a value in first cell, save it
make a virgin default template, put a value in first 2 cells, save it
make a virgin default template, put a value in first 2 cells, and in the cell A2, save it
( Initially, when I put values in, I wont hit the Enter after: Initially I want to avoid purposely doing something that may introduce a carriage return or line feed. I will then look further at that issue later )
After this I will investigate the made files , ( using , for example, my Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) ) ' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string ' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13699&viewfull=1#post13699

Here are the results ( It is a summary of what my function tells me is in those made files ) :

CSV (Comma delimited)Empty.csv
vbCr & vbLf

CSV (Macintosh)Empty.csv
vbCr & vbLf

CSV (MS-DOS)Empty.csv
vbCr & vbLf

CSV (Comma delimited)A1.csvcellA1
"cellA1" & vbCr & vbLf

CSV (Macintosh)A1.csvcellA1
"cellA1" & vbCr & vbLf

CSV (MS-DOS)A1.csvcellA1
"cellA1" & vbCr & vbLf

CSV (Comma delimited)A1B1.csvcellA1;cellB1
"cellA1" & ";" & "cellB1" & vbCr & vbLf

CSV (Macintosh)A1B1.csvcellA1;cellB1
"cellA1" & ";" & "cellB1" & vbCr & vbLf

CSV (MS-DOS)A1B1.csvcellA1;cellB1
"cellA1" & ";" & "cellB1" & vbCr & vbLf

CSV (Comma delimited)A1B1A2.csvcellA1;cellB1
callA2;
"cellA1" & ";" & "cellB1" & vbCr & vbLf & "callA2" & ";" & vbCr & vbLf

CSV (Macintosh)A1B1A2.csvcellA1;cellB1
callA2;
"cellA1" & ";" & "cellB1" & vbCr & "callA2" & ";" & vbCr & vbLf

CSV (MS-DOS)A1B1A2.csvcellA1;cellB1
callA2;
"cellA1" & ";" & "cellB1" & vbCr & vbLf & "callA2" & ";" & vbCr & vbLf

Important Conclusions are
_ the Macintosh distinguishes itself with a carriage return character, vbCr , as the line separator for introduced lines
_ There is always a last vbCr & vbLf – Note this means that for a single line, or empty file, we could not tell if we had a Macintosh

When closing the file, I was prompted to answer if I wanted to save changes or not. ( I chose yes in the last experiment ). This is strange since I had previously saved the files before closing
DoYouWantToSaveChangesOnCloseDespiteAlreadySavedCS V.JPG : https://imgur.com/nfnVwSF
But it does not seem to have any effect if I chose Yes or No
Some other observations.
If I use a simple macro, as below, to save and close the file ( and except the changes, which I am still strangely asked for , with Yes), then I get commas instead for the separator/delimiter

Sub SaveCSVviaVBA()
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
I get the same results for answering No

These macros gives me the same results

Sub SaveAsCSVviaVBA()
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "csv Text file Chaos\" & "CSV (Comma delimited)A1B1A2" & ".csv"
ActiveWorkbook.Close
End Sub

Sub SaveAsCSVviaVBAxlcsv()
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "csv Text file Chaos\" & "CSV (Comma delimited)A1B1A2" & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close
End Sub

Ref
https://excelfox.com/forum/showthread.php/126-VBA-Code-to-Clear-the-Immediate-Window
https://excelfox.com/forum/showthread.php/333-Get-Field-from-Delimited-Text-String
https://excel.tips.net/T002519_Comma-Delimited_Differences_for_PC_and_Mac.html
https://excelribbon.tips.net/T010280_Comma-Delimited_Differences_for_PC_and_Mac
https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/conversions/wbs-to-csvs?authuser=0
https://excelribbon.tips.net/T009508_Comma-Delimited_and_MS-DOS_CSV_Variations.html

Eileen’sLoungeTextFiles
http://www.eileenslounge.com/viewtopic.php?p=274367#p274367

https://excel.tips.net/T003232_Specifying_a_Delimiter_when_Saving_a_CSV_F ile_in_a_Macro.html -- printer line save ……. This works this way by design in VBA. The Excel implementation of the export routines for VBA always use whatever the Windows regional settings are to determine how items in a CSV should be separated. Specifically, the routine looks at the List Separator field for the delimiter. This means that you can, if desired, change the delimiter to a semicolon by changing the List Separator setting in your regional settings configuration.
If you don't want to change the regional settings, then you can instead write your own macro that will output the file in any way you desire. Consider, for a moment, the following macro, which will output the file:

DocAElstein

06-16-2020, 11:14 AM

Strange saving of “csv” files in Excel
Lets clarify and look in more detail at the strange saving of the files. In addition when we do it manually, we will run a macro recording
We will concentrate on the CSV (______)A1B1A2.csv

Comma delimited
Initially, if you are starting from Excel with more than one worksheet showing, then an initial pop up warns you of this:
PopUpWarningOfMultipleSheets.JPG : https://imgur.com/QLscU1a
https://i.imgur.com/QLscU1a.jpg

This initial pop up will not be shown if you have just one sheet showing at the Save stage

Assuming we have said OK at the above pop up, or have not had this pop up, we examine now the set of pop ups that occur always..
In both cases answering with Yes
On the SaveAs ( or Save ) I get this prompt
SaveAs or Save CSV (Comma delimited).JPG : : https://imgur.com/SQPHjWI
WarningOnManualSaveOrSaveAScsv(Comma delimited).JPG : https://imgur.com/QiH8phI
https://i.imgur.com/QiH8phI.jpg

and these 2 prompts on the Close, ( the second of which is identical to that from the Save or SaveAs )
this first being strange since I already just Saved the file
AskToSaveTheChangesAfterSave CSV (Comma delimited).JPG : : https://imgur.com/8ih47Ty
FirstWarningOnManualClose CSV (Comma delimited).jpg : https://imgur.com/dAxojzW
https://i.imgur.com/dAxojzW.jpg

The second is identical to that on the save : https://imgur.com/SQPHjWI
SecondWarningOnManualClose CSV (Comma delimited).JPG : https://imgur.com/TY9eBqq
https://i.imgur.com/TY9eBqq.jpg

The files as seen in test editor, or from my function, after is like
CellA1;CellA2
CellA3;
The given macro coding from the macro recorder.

Sub CSVTests()
ActiveWorkbook.SaveAs Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\csv Text file Chaos\CSV (Comma delimited)A1B1A2.csv", FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Save: ActiveWindow.Close
End Sub

If I answer No for the attempt at Save or SaveAs, then I will get the option to save as an Excel file
Answer No on SaveAs or Save CSV (Comma delimited).JPG : https://imgur.com/uXWo8vz

If I answer Yes for the attempt at Save or SaveAs, but then on Close , answer No to the first prompt, then I get that first prompt only: I don’t get the second prompt. But,
_there is a no difference in the macro from the macro recorder
and
_there is no difference in the file seen in a text editor after.

Should I now open manually the file, I find that the file has the values put, one in each cell, to reproduce the file such that it looks exactly as I created it originally
If I run the macro obtained from the macro recorder, then on the SaveAs or Save , I don’t get any prompt
On Close I get the first prompt only
DoYouWantToSaveChangesOnCloseDespiteAlreadySavedCS V with maco.JPG : https://imgur.com/BihBGOH
If I answer Yes or No , the file is saved without the second prompt as was the manual case.
Strangely, my file as seen in a text editor is different to that obtained whilst manually doing the recording: It has now commas as the separator/delimiter
cellA1,cellB1
cellA2,
Should I open this now manually, I will find that my row data is spit as before, but , I loose the columns, - that is to say the entire row information, including the , separator appear in the first column. So what is happening is that the , separator is not being recognised as a separator, and instead is being taken as pure text: My file is being seen as a text file having just rows of text, with no separator: In other words it could be regarded as a text file intended to hold the text values to be inserted into column A of an Excel File-
Row\Col
A
B

1CellA1,CellA2

2CellA3,

The conclusions are that manually closing I always get the ; as separator/delimiter, and by closing with a macro I always get the ,
Lets just say that again in another way. I do anything manually, and I end up with ; as the separator
I do anything with a macro and I end up with the , as separator.
Even if I record a macro when doing it manually, that same macro if run later will end up giving me the , as separator. This last point is likely to be a source of possible confusion

Just for completeness, the next post will check the same for saving as CSV Macintosh and CSV MS-DOS

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://eileenslounge.com/viewtopic.php?p=316254#p316254 (https://eileenslounge.com/viewtopic.php?p=316254#p316254)
https://eileenslounge.com/viewtopic.php?p=316280#p316280 (https://eileenslounge.com/viewtopic.php?p=316280#p316280)
https://eileenslounge.com/viewtopic.php?p=315915#p315915 (https://eileenslounge.com/viewtopic.php?p=315915#p315915)
https://eileenslounge.com/viewtopic.php?p=315512#p315512 (https://eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315744#p315744 (https://eileenslounge.com/viewtopic.php?p=315744#p315744)
https://www.eileenslounge.com/viewtopic.php?p=315512#p315512 (https://www.eileenslounge.com/viewtopic.php?p=315512#p315512)
https://eileenslounge.com/viewtopic.php?p=315680#p315680 (https://eileenslounge.com/viewtopic.php?p=315680#p315680)
https://eileenslounge.com/viewtopic.php?p=315743#p315743 (https://eileenslounge.com/viewtopic.php?p=315743#p315743)
https://www.eileenslounge.com/viewtopic.php?p=315326#p315326 (https://www.eileenslounge.com/viewtopic.php?p=315326#p315326)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40752 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40752)
https://eileenslounge.com/viewtopic.php?p=314950#p314950 (https://eileenslounge.com/viewtopic.php?p=314950#p314950)
https://www.eileenslounge.com/viewtopic.php?p=314940#p314940 (https://www.eileenslounge.com/viewtopic.php?p=314940#p314940)
https://www.eileenslounge.com/viewtopic.php?p=314926#p314926 (https://www.eileenslounge.com/viewtopic.php?p=314926#p314926)
https://www.eileenslounge.com/viewtopic.php?p=314920#p314920 (https://www.eileenslounge.com/viewtopic.php?p=314920#p314920)
https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837 (https://www.eileenslounge.com/viewtopic.php?f=30&t=40533&p=314837#p314837)
https://www.eileenslounge.com/viewtopic.php?f=21&t=40701&p=314836#p314836 (https://www.eileenslounge.com/viewtopic.php?f=21&t=40701&p=314836#p314836)
https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314621#p314621 (https://www.eileenslounge.com/viewtopic.php?f=27&t=40621&p=314621#p314621)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

DocAElstein

06-27-2020, 02:57 PM

This post repeats the processes and discussions of last post for saving as CSV Macintosh and CSV MS-DOS. ( We will assume we only have one worksheet showing at the start , so will not have the initial pop up warning ( https://imgur.com/QLscU1a )

Macintosh
We record a macro whilst doing Save, SaveAs , Close.
We find that we get the following warnings, answering always Yes

Save or SaveAs
WarnugOnSaveOrSaveAsMacintoshCSV.JPG : https://imgur.com/jCJ5XjK
https://i.imgur.com/jCJ5XjK.jpg

Close
WarningOnCloseForSavingChangesDespiteAlreadySavedM acintoshCSV.jpg : https://imgur.com/sShcoNq
https://i.imgur.com/sShcoNq.jpg
SecondWarningOnClose SameAsWarningOnSaveOrSaveAsMacintoshCSV.JPG : https://imgur.com/Q20iknI
https://i.imgur.com/Q20iknI.jpg

Here is the macro obtained from the recorder.

Sub SaveSaveAsCloseMacintoshCSV() ' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=13741&viewfull=1#post13741
' Save manually
ActiveWorkbook.Save
' SaveAs manually
ActiveWorkbook.SaveAs Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\csv Text file Chaos\CSV (Macintosh)A1B1A2.csv", FileFormat:=xlCSVMac, CreateBackup:=False
' Warnings same for both: https://imgur.com/jCJ5XjK

' Close manually
ActiveWorkbook.Save: ActiveWorkbook.Close
' two warnings obtained : https://imgur.com/sShcoNq , https://imgur.com/Q20iknI
End Sub

This is what it the produced text file, like in a text editor
answering always Yes
cellA1;cellB1cellA2;

Note: if I copy and paste that into Word, then I get
cellA1;cellB1
callA2;

Analysing what is there I see the typical results expected for a Macintosh csv file
"cellA1" & ";" & "cellB1" & vbCr & "callA2" & ";" & vbCr & vbLf

If I say No on the Close, then I get only that warning: The file closes without the second warning. But the results are the same

If I run the recorded macro, ( on a newly made file ) , then there is no warning pop up on Save or SaveAs. I just get the single warning asking me if I want to save the changes on Close ( despite already with the preceding coding having Saved and SaveAsd and Saved before the Close
MacroRunWarningOnCloseForSavingChangesDespiteAlrea dySavedMacintoshCSV.JPG : https://imgur.com/KYp1AYw
The resulting text file has commas , for the separator
CellA1,CellB1CellA2,
I get the same results if I answer Yes or No to the warning

CSV (MS-DOS)
We record a macro on Save, SaveAs , Close. We get the following warnings, answering always Yes

Save or SaveAs
Manual SaveAs or Save CSV (MS-DOS) warning.JPG : https://imgur.com/vkikEUS
https://i.imgur.com/sCPSmFX.jpg

Close
Manual Close CSV (MS-DOS) first warning.JPG : https://imgur.com/uvh64E6
https://i.imgur.com/uvh64E6.jpg
Manual Close CSV (MS-DOS) second warning.JPG : https://imgur.com/sCPSmFX
https://i.imgur.com/vkikEUS.jpg

This macro is obtained

Sub ManualSaveSaveAsCloseCSV_MS_DOS_()
' Manual Save
ActiveWorkbook.Save
' Manual SaveAs
ActiveWorkbook.SaveAs Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\csv Text file Chaos\CSV (MS-DOS)A1B1A2.csv", FileFormat:=xlCSVMSDOS, CreateBackup:=False
' warning same for both https://imgur.com/vkikEUS

' Close manually
ActiveWorkbook.Save: ActiveWindow.Close
' two warnings obtained https://imgur.com/uvh64E6 , https://imgur.com/sCPSmFX
End Sub

If I say No on the Close, then I get only that warning: The file closes without the second warning. But the results are the same.

The resulting text file looks like this
cellA1;cellB1
callA2;

If I run the macro produced from the macro recording, then I only get the first warning on at the Close
MacroRunWarningOnCloseForSavingChangesDespiteAlrea dySavedCSVMSDOS.JPG : https://imgur.com/aCzwGqa
https://i.imgur.com/aCzwGqa.jpg

It makes no difference if I answer Yes or No
The results are that I get a file with comma , as the delimiter
cellA1,cellB1
callA2,

Final Conclusions on Save SaveAs Close for the 3 CSV file types
The following conclusions are in general identical for the three CSV types
In my Excel, if I try to save or close manually a file as CSV type, then the separator becomes a ;
Any attempt to do the same with a macro always results in a , as the separator, ( even if the macro had been derived from a macro recording when doing it manually which resulted in the ; as separator ).
It makes no difference to the results by selecting a YES or No on any of the two possible prompts on a Close.
( The single prompt on a Save or SaveAs gives me the chance to go back to the save dialogue to choose an extension other than .csv)

DocAElstein

07-17-2020, 01:23 AM

test

PK ! U6»+w ( Ø[Content_Types].xml ¢Ô(* ÌTËNÃ0¼#ñ‘¯(q[B¨i<ŽP ø co«ŽmyÝÒþ=›¤* Ñ¨¥=pI%;3žÌp¼¬L²€€ÚÙœõ³KÀJ§´æì íõ1½a Fa•0ÎBÎV€l<:?¾®<`BÓsVÆèo9GYB%0s,½)\¨D¤Ç0å^È™˜ôz×\:ÁÆ4 Öl4|&A+H&"Ä'Q_
Úk?#<–Üµƒ5wÎ„÷FKI9_Xõƒ5uE¡%('çqe
ØEÂwb\À£©Ð
K€X™¬Ý0ßC!æ&&Kr*5=€ÁÃŽ¶63£ÉæøXjÝÞu{òáÂìÝ¹Ù©]©ÝÉ*¡íF÷ŽÔü•È›ÛÕ‰…lñ»tPŠ&Áyä”¹£ù¡^½•z‚„5lw·§ƒ£5|è^Ð¹ýn½‹Ë ¢ãøvø›XŠ ê%jË“×ÆWì½²)]€Ã²é’zú—Dò¦çGŸ ÿÿ PK ! µU0#õ L Î_rels/.rels ¢Ê(*

PK ! U6»+w ( Ø [Content_Types].xml ¢Ô ( ÌTËNÃ0 ¼#ñ ‘¯(q[ B¨i <ŽP ø co «ŽmyÝÒþ=›¤* Ñ¨¥=pI %;3žÌp¼¬L²€€ÚÙœõ³ KÀJ§´æìíõ1½a Fa•0ÎBÎV€l<:? ¾®<`BÓ sVÆèo9GYB%0s ,½)\¨D¤Ç0å^È™˜ -ôz×\: ÁÆ4Ö l4|& A+H&"Ä'Q _ Úk?#<–Üµƒ5wÎ„÷FK I9_Xõƒ5uE¡%('ç qe ØEÂw b\ À£©Ð
K€X™¬ Ý0ßC!æ&& Kr 5=€ÁÃŽ¶63£ÉæøXj
ÝÞu{òáÂìÝ¹Ù©]©ÝÉ*¡íF÷Ž Ôü•È›ÛÕ‰…lñ»tPŠ&Áyä”¹£ù¡^½ •z‚„ 5lw•§ƒ£5|è^ Ð ¹ýn½‹Ë¢ãøvø›¬XŠ ê% jË“×ÆWì½²)]€Ã ²é’zú—Dò¦çGŸ ÿÿ PK ! µU0#õ L
Î _rels/.rels ¢Ê (

DocAElstein

07-20-2020, 03:19 PM

Post for later use

DocAElstein

11-24-2020, 01:45 PM

Post for later use to keep order, and to get URL now for an index page in Blog post

DocAElstein

11-24-2020, 01:45 PM

Post for later use to keep order, and to get URL now for an index page in Blog post -

DocAElstein

11-24-2020, 01:46 PM

Post for later use to keep order, and to get URL now for an index page in Blog post --

DocAElstein

11-24-2020, 01:46 PM

Post for later use to keep order, and to get URL now for an index page in Blog post ...

DocAElstein

11-24-2020, 01:46 PM

Post for later use to keep order, and to get URL now for an index page in Blog post ....

DocAElstein

11-24-2020, 02:23 PM

For Ozgrid post results see here: https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15144&viewfull=1#post15144

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35732

'
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String, Optional ByVal FlNme As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim Ws As Worksheet '
Set Ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
Ws.Activate: Ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let Ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set Ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add After:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = FlNme & vbLf & Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
Case ","
Let WotchaGot = WotchaGot & """" & "," & """" & " & "
Case ";"
Let WotchaGot = WotchaGot & """" & ";" & """" & " & "
Case ":"
Let WotchaGot = WotchaGot & """" & ":" & """"
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Dim Lr1 As Long: Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Let Ws1.Range("A" & Lr1 + 1 & "").Value = FlNme
Let Ws1.Range("B" & Lr1 + 1 & "").Value = strIn
Let Ws1.Range("C" & Lr1 + 1 & "").Value = WotchaGot
Ws1.Cells.Columns.AutoFit
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
Ws.Activate: Ws.Cells.Item(1, 1).Activate
If Not Ws.Range("A1").Value = "" Then Let NxtClm = Ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let Ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
Ws.Cells.Columns.AutoFit
End Sub
'
' https://excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort-Last-Row?p=7214#post7214
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

' Lets have a look at a bit of the text file
Sub LookInFirstBitOfTextString()
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, FlNme As String
Let PathAndFileName = ThisWorkbook.Path & "\" & "ttFirstBit" '
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile, FlNme)
End Sub

Share ‘tt_ExtraminationsRock.xlsm’ : https://app.box.com/s/z3nr7ecnj540rond1437bo48wmaxsbch
Share ‘ttFirstBit.txt’ : https://app.box.com/s/zzeqis8qhdfbzj68fzyficdfszh2tjoo

DocAElstein

11-24-2020, 02:36 PM

continued from last post

ttFirstBit.txt

Playlist Name Curator Genres Followers Best Way To Contact Spotify Link
felix@pro-gamer-gear.de
8,350
#1 Gaming Playlist Felix Krissmayr RAP, ROCK, HIP HOP, POST-GRUNGE, EDM, POP, HARD ROCK,

ELECTRONIC, PROGRESSIVE HOUSE, INDIETRONICA, METAL, SOUNDTRACK, PUNK, BROSTEP, HOUSE

https://open.spotify.com/playlist/1DRpqg3Vlub1gKMWN14gCg
#Part?y

After running macro

Sub LookInFirstBitOfTextString()
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, FlNme As String
Let FlNme = "ttFirstBit.txt"
Let PathAndFileName = ThisWorkbook.Path & "\" & FlNme '
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile, FlNme)
End Sub

results:

vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "Playlist" & " " & "Name" & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "Curator" & " " & " " & " " & " " & " " & " " & " " & "Genres" & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "Followers" & " " & " " & " " & " " & "Best" & " " & "Way" & " " & "To" & " " & "Contact" & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "Spotify" & " " & "Link" & vbCr & vbLf & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "
" & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "felix" & Chr(64) & "pro" & "-" & "gamer" & "-" & "gear" & "." & "de" & vbCr & vbLf & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & "8" & "," & "350" & vbCr & vbLf & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & Chr(35) & "1" & " " & "Gaming" & " " & "Playlist" & " " & " " & " " & " " & " " & "Felix" & " " & "Krissmayr" & " " & " " & "RAP" & ","
& " " & "ROCK" & "," & " " & "HIP" & " " & "HOP" & "," & " " & "POST" & "-" & "GRUNGE" & "," & " " & "EDM" & "," & " " & "POP" & "," & " " & "HARD" & " " & "ROCK" & "," & " " & "ELECTRONIC" & "," & " " & "PROGRESSIVE" & " " & "HOUSE" & "," & " " & "INDIETRONICA" & "," & " " & "METAL" & "," & " " & "SOUNDTRACK" & "," & " " & "PUNK" & "," & " " & "BROSTEP" & "," & " " & "HOUSE" & vbCr & vbLf & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " "
& " " & " " & " " & " " & " " & " " & " " & " " & "https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "1DRpqg3Vlub1gKMWN14gCg" & vbCr & vbLf & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & " " & Chr(35) & "Part" & "?" & "y"

DocAElstein

11-24-2020, 04:15 PM

continued from last post

Sub ConventionalTextImport() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35100&p=274367#p274367 http://www.eileenslounge.com/viewtopic.php?f=30&t=34629&p=274370#p274370 http://www.eileenslounge.com/viewtopic.php?p=274721#p274721
Rem 1 Worksheets info, (any worksheet will do to paste out to)
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item("ConventionalTextImport")
Rem 2 Text file info
' 2a) get the text file 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 & "tt.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile: Debug.Print TotalFile
Close #FileNum
' Let TotalFile = Replace(TotalFile, """", "", 1, -1, vbBinaryCompare): Debug.Print TotalFile ' removed enclosing quotes in rabsofty's text file
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)
' 2b) Split into wholes line _ splitting the text file into rows by splitting by Line Seperator
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
'' 2c) split first line to determine the Field(column) number
'Dim arrClms() As String: Let arrClms() = Split(arrRws(0), ",", -1, vbBinaryCompare)
'Dim ClmCnt As Long: Let ClmCnt = UBound(arrClms()) + 1
Dim ClmCnt As Long: Let ClmCnt = 1
' 2d) we can now make an array for all the rows, and we know our columns are A-J = 10 columns
Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To ClmCnt)

Rem 3 An array is built up by _....
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data
'Dim arrClms() As String
' Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
' Dim Clm As Long '
' For Clm = 1 To UBound(arrClms()) + 1
' Let arrOut(Cnt, Clm) = arrClms(Clm - 1) ' At each of these "inner" loops we fill either a the array with an element
Let arrOut(Cnt, 1) = arrRws(Cnt - 1)
' Next Clm
Next Cnt

Rem 4 Finally the array is pasted to worksheet
Dim RngOut As Range: Set RngOut = Ws1.Range("A1").Resize(RwCnt, ClmCnt)
RngOut.ClearContents
Let RngOut.Value = arrOut()
' 4b Option to remove the little ... when i click on any cell that has output there is an option numbers stored as text, convert to numbers,help on this error,ignore error,edit in formula bar,error checking options(these are the options coming)…
Let RngOut.Value = Evaluate("=IF(" & RngOut.Address & "="""","""",IF(ISNUMBER(1*" & RngOut.Address & "),1*" & RngOut.Address & "," & RngOut.Address & "))") ' http://www.eileenslounge.com/viewtopic.php?p=272704#p272704
End Sub

DocAElstein

11-25-2020, 02:47 AM

tt2.txt

vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & " Playlist Name Curator Genres Followers Best Way To Contact Spotify Link" & vbCr & vbLf & " felix" & Chr(64) & "pro" & "-" & "gamer" & "-" & "gear" & "." & "de" & vbCr & vbLf & " 8" & "," & "350" & vbCr & vbLf & " " & "#" & "1 Gaming Playlist Felix Krissmayr RAP" & "," & " ROCK" & "," & " HIP HOP" & "," & " POST" & "-" & "GRUNGE" & "," & " EDM" & "," & " POP" & "," & " HARD ROCK" & "," & " ELECTRONIC" & "," & " PROGRESSIVE HOUSE" & "," & " INDIETRONICA" & "," & " METAL" & "," & " SOUNDTRACK" & "," & " PUNK" & "," & " BROSTEP" & "," & " HOUSE" & vbCr & vbLf & " https" & ":" & "/
" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "1DRpqg3Vlub1gKMWN14gCg" & vbCr & vbLf & " " & "#" & "Part" & "?" & "y handiofiblood ROCK" & "," & " POP" & "," & " R" & "&" & "B" & "," & " EDM" & "," & " HIP HOP 1" & "," & "816 handofblood" & Chr(64) & "instinct3" & "." & "de https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "0Zx5bp0guBk949wzBoxMQX" & vbCr & vbLf & " http" & ":" & "/" & "/" & "reddit" & "." & "com" & "/" & "r" & "/" & "listentothis" & vbCr & vbLf & " " & "/" & "r" & "/" & "listentothis Andreas Karlsson SINGER" & "/" & "SONGWRITER" & "," & " DANCE" & "," & " POP" & "," & " INDIE" & "," & " REGGAE" & "," & " ROCK" & "," & " INDIE ROCK" & "," & " POP PUNK" & "," & " ALTERNATIVE" & "," & " PUNK" & "," & " HIP HOP" & "," & " PSYCHEDELIC https" & ":" & "/" & "/" & "open" & "." & "s
potify" & "." & "com" & "/" & "playlist" & "/" & "6qZnImkqxbRtL9FiwqHkGK" & vbCr & vbLf & " 17" & "," & "311" & vbCr & vbLf & " 100" & "+" & " best new alternative " & "&" & " indie hits Trackdiggers INDIE" & "," & " ALTERNATIVE" & "," & " FOLK" & "-" & "POP" & "," & " INDIE POP" & "," & " INDIETRONICA" & "," & " DANCE PUNK" & "," & " TRIPHOP" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " CHILLWAVE" & "," & " PREVERB" & "," & " ELECTRONIC" & "," & " PSYCHEDELIC" & vbCr & vbLf & " 382" & vbCr & vbLf & " trackdiggers" & Chr(64) & "gmail" & "." & "com" & vbCr & vbLf & " https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "
/" & "playlist" & "/" & "2GsA39IcGmgHldG8Jyqok6" & vbCr & vbLf & " info" & Chr(64) & "spingrey" & "." & "com" & vbCr & vbLf & " 21" & "," & "410" & vbCr & vbLf & " A Sunday Spring SpinGrey POP" & "," & " R" & "&" & "B" & "," & " INDIE" & "," & " INDIETRONICA" & "," & " RAP" & "," & " INDIE POP" & "," & " HIP HOP" & "," & " SOUL" & "," & " FUNK" & "," & " FOLK" & "-" & "POP" & "," & " ROCK https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "1KpzhrvBZHfwnXayCMAQiY" & vbCr & vbLf

DocAElstein

11-26-2020, 02:45 PM

tt.txt

Approximately a quarter of it:-

vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & " Playlist Name Curator Genres Followers Best Way To Contact Spotify Link" & vbCr & vbLf & " felix" & "@" & "pro" & "-" & "gamer" & "-" & "gear" & "." & "de" & vbCr & vbLf & " 8" & "," & "350" & vbCr & vbLf & " " & "#" & "1 Gaming Playlist Felix Krissmayr RAP" & "," & " ROCK" & "," & " HIP HOP" & "," & " POST" & "-" & "GRUNGE" & "," & " EDM" & "," & " POP" & "," & " HARD ROCK" & "," & " ELECTRONIC" & "," & " PROGRESSIVE HOUSE" & "," & " INDIETRONICA" & "," & " METAL" & "," & " SOUNDTRACK" & "," & " PUNK" & "," & " BROSTEP" & "," & " HOUSE" & vbCr & vbLf & " https" & ":" & "/" &
"/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "1DRpqg3Vlub1gKMWN14gCg" & vbCr & vbLf & " " & "#" & "Part" & "?" & "y handiofiblood ROCK" & "," & " POP" & "," & " R" & "&" & "B" & "," & " EDM" & "," & " HIP HOP 1" & "," & "816 handofblood" & "@" & "instinct3" & "." & "de https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "0Zx5bp0guBk949wzBoxMQX" & vbCr & vbLf & " http" & ":" & "/" & "/" & "reddit" & "." & "com" & "/" & "r" & "/" & "listentothis" & vbCr & vbLf & " " & "/" & "r" & "/" & "listentothis Andreas Karlsson SINGER" & "/" & "SONGWRITER" & "," & " DANCE" & "," & " POP" & "," & " INDIE" & "," & " REGGAE" & "," & " ROCK" & "," & " INDIE ROCK" & "," & " POP PUNK" & "," & " ALTERNATIVE" & "," & " PUNK" & "," & " HIP HOP" & "," & " PSYCHEDELIC https" & ":" & "/" & "/" & "open" & "." & "spotify"
& "." & "com" & "/" & "playlist" & "/" & "6qZnImkqxbRtL9FiwqHkGK" & vbCr & vbLf & " 17" & "," & "311" & vbCr & vbLf & " 100" & "+" & " best new alternative " & "&" & " indie hits Trackdiggers INDIE" & "," & " ALTERNATIVE" & "," & " FOLK" & "-" & "POP" & "," & " INDIE POP" & "," & " INDIETRONICA" & "," & " DANCE PUNK" & "," & " TRIPHOP" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " CHILLWAVE" & "," & " PREVERB" & "," & " ELECTRONIC" & "," & " PSYCHEDELIC" & vbCr & vbLf & " 382" & vbCr & vbLf & " trackdiggers" & "@" & "gmail" & "." & "com" & vbCr & vbLf & " https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playli
st" & "/" & "2GsA39IcGmgHldG8Jyqok6" & vbCr & vbLf & " info" & "@" & "spingrey" & "." & "com" & vbCr & vbLf & " 21" & "," & "410" & vbCr & vbLf & " A Sunday Spring SpinGrey POP" & "," & " R" & "&" & "B" & "," & " INDIE" & "," & " INDIETRONICA" & "," & " RAP" & "," & " INDIE POP" & "," & " HIP HOP" & "," & " SOUL" & "," & " FUNK" & "," & " FOLK" & "-" & "POP" & "," & " ROCK https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "1KpzhrvBZHfwnXayCMAQiY" & vbCr & vbLf & " 4" & "," & "510" & vbCr & vbLf & " https" & ":" & "/" & "/" & "www" & "." & "instagram" & "." & "com" & "/" & "andrewduong77" & vbCr & vbLf &
" Adult Contemporary" & "," & " Soft Rock" & "," & " Pop Andrew Duong SOFT ROCK" & "," & " POP" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " DISCO" & "," & " R" & "&" & "B" & "," & " HARD ROCK" & "," & " MOTOWN" & "," & " POST" & "-" & "GRUNGE" & "," & "FUNK" & "," & " SYNTH POP" & "," & " FOLK" & "," & " SOUL" & "," & " COUNTRY" & "," & " FOLK POP https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "7iLpBTFFlNJNUfGuiJdvqw" & vbCr & vbLf & " tinydesk" & "@" & "bobboilen" & "." & "info" & vbCr & vbLf & " All Songs Considered NPR Music INDIE ROCK" & "," & " ALTERNATIVE" & "," & " ROCK" & "," & " FOLK" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " SOUL" & "," & " R" & "&" & "B" & "," & " ROOTS" & "," & " HIP HOP" & "," & "BLUEGRASS" & "," & " BLUES" & "," & " POP" & "," & " INDIETRONICA" & "," & " PUNK" & "," & " HARDCORE" & "," & " WORLD
MUSIC" & vbCr & vbLf & " 20" & "," & "095" & vbCr & vbLf & " https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "7ro9wf8vuSLGxStaC8t8Rv" & vbCr & vbLf & " 36" & "," & "180" & vbCr & vbLf & " Alternative Rap Bangers Marcin Mrotek HIP HOP" & "," & " ALTERNATIVE" & "," & " ROCK" & "," & " INDIE ROCK" & "," & " POP altrockplaylist" & "@" & "gmail" & "." & "com https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "7xBH6HAUcaxLpAK5xv0Gso" & vbCr & vbLf & " 157" & "," & "723" & vbCr & vbLf & " alxrnbrdmusic Playlists alexrainbirdmusic INDIE POP" & ","
& " INDIE ROCK" & "," & " FOLK" & "," & " FOLK" & "-" & "POP" & "," & " ACOUSTIC" & "," & " ROCK" & "," & " POP" & "," & " ALTERNATIVE alexrainbirdmusic" & "@" & "gmail" & "." & "com https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "user" & "/" & "alxrnbrdmusic" & vbCr & vbLf & " Anthropologie carolinejoyrector ROOTS" & "," & " AMERICANA" & "," & " FOLK" & "-" & "POP" & "," & " POP" & "," & " SOUL" & "," & " INDIE ROCK unfancyblog" & "@" & "gmail" & "." & "com https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "1UzFdewdE4cqe53CUU3J0D" & vbCr & vbLf & " 1" & "," & "131" & vbCr & vbLf & " Audiophile Reference Headphone Bliss losshack POP" & "," & " ROCK" & "," & " INDIE" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " BLUES" & "," & " INSTRUMENTAL" & "," & " FOLK" & "-" & "POP losshack" & "@" & "gmail" & "." & "com htt
ps" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "55hNEtHhJ1fprtrcm1rD2I" & vbCr & vbLf & " 3" & "," & "968" & vbCr & vbLf & " Audiophile test music " & "(" & "Hifi High Quality" & ")" & " Ben Koomen POP" & "," & " JAZZ" & "," & " BLUES" & "," & " ELECTRONIC" & "," & " ACOUSTIC" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " LATIN" & "," & " CLASSICAL" & "," & "FOLK" & "," & " ROOTS https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "7gP6LVrR1OAjTI1yjTrv2h" & vbCr & vbLf & " https" & ":" & "/" & "/" & "www" & "." & "instagram" & "." & "com" & "/" & "benkoomen" & vbCr & vbLf & " 23665" & vbCr & vbLf & "
https" & ":" & "/" & "/" & "www" & "." & "instagram" & "." & "com" & "/" & "alex" & "_" & "delany" & vbCr & vbLf & " 3" & "," & "893" & vbCr & vbLf & " BA COOKING JAMS Alex Delany ROCK" & "," & " SOUL" & "," & " INDIE POP" & "," & " INDIETRONICA" & "," & " FUNK" & "," & " NEO" & "-" & "PSYCHEDELIC" & "," & " SINGER" & "/" & "SONGWRITER" & "," & "FOLK" & "-" & "POP" & "," & " POP" & "," & " RAP" & "," & " HIP HOP" & "," & " R" & "&" & "B PREVERB https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "2jHbztkuPjoBO6FN3dtoL1" & vbCr & vbLf & " Balearic Chris Coco SINGER" & "/" & "SONGWRITER" & "," & " ELECTRONIC" & "," & " ROCK" & "," & " FOLK" & "," & " SOUNDTRACK" & "," & " DEEP HOUSE" & "," & " TRIP HOP" & "," & " NEOPSYCHEDELIC" & "," & " SYNTH POP" & "," & " SOUL" & "," & " DOWNTEMPO" & "," & " INDIETRONICA" & "," &
" BOSSANOVA" & "," & " DISCO" & "," & " MPB" & "," & " SAMBA" & "," & " EXPERIMENTAL" & "," & " FOLK POP" & "," & " CHILLWAVE" & "," & " LO" & "-" & "FI" & "," & " AMBIENT" & "," & " WORLD" & vbCr & vbLf & " https" & ":" & "/" & "/" & "www" & "." & "instagram" & "." & "com" & "/" & "djchriscoco" & vbCr & vbLf & " https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "100icvOSPBO4Mk5pYgALx4" & vbCr & vbLf & " 4" & "," & "945" & vbCr & vbLf & " INDIE POP" & "," & " INDIETRONICA" & "," & " FOLK" & "-" & "POP" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " ROCK" & "," & " POP" & "," & " REGGAE" & "," & " SYNTHPOP" & "," & vbCr & vbLf & "
Beach Music Kyle DeBruyn PSYCHEDELIC" & "," & " POST" & "-" & "GRUNGE 75" & "," & "220 https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "4UiM5IjpEO4sOnxD9hork2" & vbCr & vbLf & " 3" & "," & "551" & vbCr & vbLf & " Beach Vibes Caltify MX POP" & "," & " INDIETRONICA" & "," & " DREAM POP" & "," & " R" & "&" & "B" & "," & " FUNK" & "," & " SOUL" & "," & " POP" & "," & " RAP" & "," & " HIP HOP cesar98luna" & "@" & "hotmail" & "." & "com https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "6Y7JOodQbBZllGNsmTuFRQ" & vbCr & vbLf & " 1" & "," & "020" & vbCr & vbLf & " Beautifully Crafted Tunes Alec Wilson FOLK POP" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " TRIPHOP" & "," &
" NINJA" & "," & " INDIE POP" & "," & " ELECTRONIC" & "," & " DOWNTEMPO" & "," & "INDIETRONICA" & "," & " LO" & "-" & "FI" & "," & " ROCK" & "," & " AMBIENT" & "," & " POP" & "," & " NEO" & "-" & "PSYCHEDELIC" & vbCr & vbLf & " https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "17TXcS1H8xhxVuVN4rMBTy" & vbCr & vbLf & " https" & ":" & "/" & "/" & "www" & "." & "facebook" & "." & "com" & "/" & "AlecWilsonIndependentPlaylister" & vbCr & vbLf & " https" & ":" & "/" & "/" & "www" & "." & "instagram" & "." & "com" & "/" & "benwatt" & vbCr & vbLf & " 10" & "," & "492" & vbCr & vbLf & " Ben Watt" & C
hrW(8217) & "s SpinCycle Ben Watt SINGER" & "/" & "SONGWRITER" & "," & " FOLK" & "-" & "POP" & "," & " INDIE POP" & "," & " PREVERB" & "," & " NEO" & "-" & "PSYCHEDELIC" & "," & " FUNK" & "," & " ROCK" & "," & "INDIETRONICA" & "," & " SOUL" & "," & " LO" & "-" & "FI" & "," & " FOLK" & "," & " HIP HOP" & "," & " CHILLWAVE" & "," & " EXPERIMENTAL" & "," & " RAP" & "," & " POP" & vbCr & vbLf & " https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "0inHe5mbRJoHBtPl8dWMYg" & vbCr & vbLf & " Best New Music Nialler9 INDIE ROCK" & "," & " ALTERNATIVE" & "," & " SINGER" & "/" & "SONGWRITER" & "," & " POP" & "," & " EDM" & "," & " ELECTRONIC" & "," & " INDIETRONICA https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "0sLxjSNzBJUn1iIxT1575E" & vbCr & vbLf & "
newmusic" & "@" & "nialler9" & "." & "com" & vbCr & vbLf & " 5" & "," & "474" & vbCr & vbLf & " raiseyourhands" & "@" & "arts" & "-" & "crafts" & "." & "ca" & vbCr & vbLf & " Best New Indie" & ":" & " A" & "&" & "C Favourites Arts " & "&" & " Crafts INDIE POP" & "," & " INDIETRONICA" & "," & " NEO" & "-" & "PSYCHEDELIC" & "," & " FOLK" & "-" & "POP" & "," & " CHILLWAVE" & "," & " PREVERB" & "," & " LO" & "-" & "FI" & "," & "DANCE PUNK" & "," & " NINJA" & "," & " INDIE ROCK https" & ":" & "/" & "/" & "open" & "." & "spotify" & "." & "com" & "/" & "playlist" & "/" & "0cRVHq3mj9gLhivNwv2wj8"

DocAElstein

11-26-2020, 04:04 PM

Modified Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(
to create a text file output of the WotchaGot string
This is useful for large files, since cell content and Immediate Window text size is limited,

'3c) Output WotchaGot string to a text file
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 & "\" & "WotchaGot_in_" & Replace(FlNme, ".txt", "", 1, 1, vbBinaryCompare) & ".txt" ' CHANGE path TO SUIT
Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum2, WotchaGot ' write out entire text file
Close #FileNum2
End Sub

Share ‘WotchaGot_in_tt.txt’ : https://app.box.com/s/3hqrkgity8945tx70izjhj9e6wpaewg7
Share ‘tt_ExtraminationsRock.xls’ https://app.box.com/s/o5ka0fckmdp573tfyz9swwwir73hcnow

The output produced by the macro ( shown in worksheet “TextToTabular” ) of the uploaded file, “tt_ExtraminationsRock.xls” , is very similar to the “Sample.pdf” – I can see some discrepancies in the column for Followers This is because two numbers are completely missing from the text file ( 958 and 17145 ) –

https://i.imgur.com/q9fFtW0.jpg http://i.imgur.com/q9fFtW0.jpg https://imgur.com/q9fFtW0
https://i.imgur.com/q9fFtW0.jpg

DocAElstein

11-26-2020, 04:05 PM

Modified Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(
to create a text file output of the WotchaGot string ( in the last post it was used to produce the text file
WotchaGot_in_tt.txt )

' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string
' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String, Optional ByVal FlNme As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim Ws As Worksheet '
Set Ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
Ws.Activate: Ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let Ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set Ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add After:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = FlNme & vbLf & Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Or Caracter = " " Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]" Or Mid(strIn, Cnt - 1, 1) Like " ") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
Case ","
Let WotchaGot = WotchaGot & """" & "," & """" & " & "
Case ";"
Let WotchaGot = WotchaGot & """" & ";" & """" & " & "
Case ":"
Let WotchaGot = WotchaGot & """" & ":" & """" & " & "
Case "#"
Let WotchaGot = WotchaGot & """" & "#" & """" & " & "
Case "@"
Let WotchaGot = WotchaGot & """" & "@" & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Dim Lr1 As Long: Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Let Ws1.Range("A" & Lr1 + 1 & "").Value = FlNme
Let Ws1.Range("B" & Lr1 + 1 & "").Value = strIn
Let Ws1.Range("C" & Lr1 + 1 & "").Value = WotchaGot
Ws1.Cells.Columns.AutoFit
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
Ws.Activate: Ws.Cells.Item(1, 1).Activate
If Not Ws.Range("A1").Value = "" Then Let NxtClm = Ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let Ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
Ws.Cells.Columns.AutoFit
'3c) Output WotchaGot string to a text
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 & "\" & "WotchaGot_in_" & Replace(FlNme, ".txt", "", 1, 1, vbBinaryCompare) & ".txt" ' CHANGE path TO SUIT
Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum2, WotchaGot ' write out entire text file
Close #FileNum2
End Sub

DocAElstein

11-26-2020, 05:37 PM

Macro for this post
https://eileenslounge.com/viewtopic.php?p=277957#p277957

Sub TextFileToTabular() ' https://eileenslounge.com/viewtopic.php?p=277881#p277881
Rem 1 Worksheets info, (any worksheet will do to test paste out to)
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item("TextToTabular")
Rem 2 Text file info
' 2a) get the text file 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 & "tt.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile 'Debug.Print TotalFile
Close #FileNum
' Let TotalFile = Replace(TotalFile, """", "", 1, -1, vbBinaryCompare): Debug.Print TotalFile ' removed enclosing quotes in rabsofty's text file
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)
'2a)(ii) Some simple tidying up of complete string
Let TotalFile = Replace(TotalFile, ": http", "http", 1, -1, vbBinaryCompare) ' there are some strange : http which in combination with the next line will/ would introduce an error
Let TotalFile = Replace(TotalFile, "http", " http", 1, -1, vbBinaryCompare) ' this ensures at least two spaces before any link
' 2b) Split into wholes line _ splitting the text file into rows by splitting by Line Seperator
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' 2c) We are looping all row data: Some is single element(column) entries , some is multi element(column) data. We want to try to fill up a 6 element(column) array
Dim arrRw() As String: ReDim arrRw(1 To 6) ' we know our columns are 6 entries
' 2d) we make an array for all the final rows
Dim arrHarray() As Variant: Dim HarryCnt As Long: Let HarryCnt = 1
Dim Cnt As Long
Do While Not Cnt = RwCnt - 1 ' We are looping all row data: Some is single element(column) entries , some is multi element(column) data
'For Cnt = 1 To RwCnt
' 2c) _(A)
Do While (arrRw(1) = "" Or arrRw(2) = "" Or arrRw(3) = "" Or arrRw(4) = "" Or arrRw(5) = "" Or arrRw(6) = "") ' we try to fill all 6 element(column) data in the array, but we try to deal with some missing
If arrRws(Cnt) <> "" Then
Let Cnt = Cnt + 1
' _(B)
If InStr(1, Trim(arrRws(Cnt - 1)), " ", vbBinaryCompare) = 0 Then ' this is the case of a rouge line
' _(C)
If InStr(1, Trim(arrRws(Cnt - 1)), "@", vbBinaryCompare) <> 0 Or InStr(1, Trim(arrRws(Cnt - 1)), "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, Trim(arrRws(Cnt - 1)), "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, Trim(arrRws(Cnt - 1)), "http://reddit.com", vbBinaryCompare) <> 0 Then
If arrRw(5) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(5) = Trim(arrRws(Cnt - 1))
' _(D)
ElseIf InStr(1, Trim(arrRws(Cnt - 1)), "https://open.spotify.com/", vbBinaryCompare) <> 0 Then
If arrRw(6) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(6) = Trim(arrRws(Cnt - 1))
ElseIf IsNumeric(Trim(arrRws(Cnt - 1))) Then
If arrRw(4) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(4) = Trim(arrRws(Cnt - 1))
ElseIf InStr(1, Trim(arrRws(Cnt - 1)), ",", vbBinaryCompare) <> 0 Then
Dim ExtrGenitals As String
If ExtrGenitals <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let ExtrGenitals = Trim(arrRws(Cnt - 1))

Else
End If

Else ' we have a line with multiple data, assuming that such data is seperated by at least 2 spaces " "
Dim DataSRw As String: Let DataSRw = arrRws(Cnt - 1)
Let DataSRw = LTrim(DataSRw) & " " ' take off any preceding spaces and add a few spaces so that next Loop works for the last element
Dim posTwoSpcs As Long
Do While DataSRw <> "" ' looping to get all data from a dataS row ----
Dim ClmCnt As Long: Let ClmCnt = ClmCnt + 1
Let posTwoSpcs = InStr(1, DataSRw, " ", vbBinaryCompare)
If ClmCnt > 3 Then ' after the third entry things may be not incorrect order
Dim UnOrdedIndataSRw As String
Let UnOrdedIndataSRw = Left(DataSRw, (posTwoSpcs - 1))
If InStr(1, UnOrdedIndataSRw, "@", vbBinaryCompare) <> 0 Or InStr(1, UnOrdedIndataSRw, "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, UnOrdedIndataSRw, "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, UnOrdedIndataSRw, "http://reddit.com", vbBinaryCompare) <> 0 Then
If arrRw(5) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(5) = UnOrdedIndataSRw
ElseIf InStr(1, UnOrdedIndataSRw, "https://open.spotify.com/", vbBinaryCompare) <> 0 Then
If arrRw(6) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(6) = UnOrdedIndataSRw
Else
If arrRw(ClmCnt) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(ClmCnt) = Left(DataSRw, (posTwoSpcs - 1))
End If
Else
Let arrRw(ClmCnt) = Left(DataSRw, (posTwoSpcs - 1))
If ClmCnt = 3 And InStr(1, arrRw(3), " ", vbBinaryCompare) <> 0 And (InStr(1, arrRw(3), "@", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "http://reddit.com", vbBinaryCompare) <> 0) Then ' We may have a problem that after the Genres data has a link added with just one space that should be the fifth column (Best Way To Contact)
Dim SptGenitral() As String: Let SptGenitral() = Split(arrRw(3), " ", -1, vbBinaryCompare)
Let arrRw(5) = SptGenitral(UBound(SptGenitral))
Let arrRw(3) = Replace(arrRw(3), " " & arrRw(5), "", 1, -1, vbBinaryCompare)
Let posTwoSpcs = InStr(1, DataSRw, " ", vbBinaryCompare)
' _(B)(i) The macro will deal with some cases of Curator and Genres only being separated by one space This next bit may sort out if the Curator is in two words and is only seperated from the Playlist Name by 1 space
ElseIf InStr(1, arrRw(3), "@", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "http://reddit.com", vbBinaryCompare) <> 0 Then
Let arrRw(5) = arrRw(3)
Let arrRw(3) = arrRw(2)
Dim Spt1a() As String: Let Spt1a() = Split(arrRw(1), " ", -1, vbBinaryCompare)
Let arrRw(2) = Spt1a(UBound(Spt1a()) - 1) & " " & Spt1a(UBound(Spt1a()))
ElseIf InStr(1, arrRw(3), "https://open.spotify.com/", vbBinaryCompare) <> 0 Then
Let arrRw(6) = arrRw(3)
Let arrRw(3) = arrRw(2)
Let arrRw(1) = Replace(arrRw(1), arrRw(2), "", 1, 1, vbBinaryCompare)
Dim Spt1b() As String: Let Spt1b() = Split(arrRw(1), " ", -1, vbBinaryCompare)
Let arrRw(2) = Spt1b(UBound(Spt1b()) - 1) & " " & Spt1b(UBound(Spt1b()))
Let arrRw(1) = Replace(arrRw(1), arrRw(2), "", 1, 1, vbBinaryCompare)
End If
End If
Let DataSRw = Mid(DataSRw, posTwoSpcs)
Let DataSRw = LTrim(DataSRw)

Loop ' looping to get all data from a dataS row ----
End If
Else ' case empty row
Let Cnt = Cnt + 1 ' increase to next data row from the text file
If Cnt = RwCnt Then GoTo Bed
End If
Loop ' While (arrRw(1) = "" Or arrRw(2) = "" Or arrRw(3) = "" Or arrRw(4) = "" Or arrRw(5) = "" Or arrRw(6) = "")
Missing: ' _(A)(i) we come here if we tried to fill an already filled element, which indicates we had something missing
Let arrRw(3) = arrRw(3) & ExtrGenitals ' modify Genres string to include any appearing in a rogue line
' 2d)(ii) At this point its time to put the current completed row data into the jagged array to use late in Index
Rem 3 An array is built up by using that interesting "Index on a unjagged jagged 1Ds arrays technique" that we first noticed here: https://eileenslounge.com/viewtopic.php?p=266691#p266691 https://eileenslounge.com/viewtopic.php?p=266727#p266727 https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
ReDim Preserve arrHarray(1 To HarryCnt)
Let arrHarray(HarryCnt) = arrRw()
Let HarryCnt = HarryCnt + 1

ReDim arrRw(1 To 6) ' this resets (empties) the row array
Let ClmCnt = 0
Let ExtrGenitals = ""
Loop ' While Not Cnt = RwCnt-1
Bed: ' This section will deal with a problem of the last row in harry being missed if it is missing some data
ReDim Preserve arrHarray(1 To HarryCnt)
Let arrHarray(HarryCnt) = arrRw()
Rem 4 Finally the array is pasted to worksheet ' use of that interesting "Index on a unjagged jagged 1Ds arrays technique" that we first noticed here: https://eileenslounge.com/viewtopic.php?p=266691#p266691 https://eileenslounge.com/viewtopic.php?p=266727#p266727 https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
Dim RngOut As Range: Set RngOut = Worksheets("TextToTabular").Range("A1:F" & UBound(arrHarray()) & "")
Let RngOut.Value = Application.Index(arrHarray(), Evaluate("=row(1:" & UBound(arrHarray()) & ")"), Array(1, 2, 3, 4, 5, 6))
Worksheets("TextToTabular").Columns("A:F").AutoFit
'' 4b Option to remove the little ... when i click on any cell that has output there is an option numbers stored as text, convert to numbers,help on this error,ignore error,edit in formula bar,error checking options(these are the options coming)…
' Let RngOut.Value = Evaluate("=IF(" & RngOut.Address & "="""","""",IF(ISNUMBER(1*" & RngOut.Address & "),1*" & RngOut.Address & "," & RngOut.Address & "))") ' http://www.eileenslounge.com/viewtopic.php?p=272704#p272704
End Sub

DocAElstein

11-27-2020, 12:33 PM

In support of this Thread
https://www.ozgrid.com/forum/index.php?thread/1228586-import-certain-data-from-comma-seperated-text-file-to-excel/&postID=1241623#post1241623

"-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & " " & vbCr & vbLf & "This is a report for last week " & vbCr & vbLf & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & " " & vbCr & vbLf & " " & vbCr & vbLf & "Date" & "," & "RunbookBCompletionTime " & vbCr & vbLf & "20201116" & "," & "05" & ":" & "44 AM" & vbCr & vbLf & "20201117" & "," & "05" & ":" & "47 AM" & vbCr & vbLf & "20201118" & "," & "05" & ":" & "39 AM" & vbCr & vbLf & "20201119" & "," & "06" & ":" & "10 AM" & vbCr & vbLf & "20201120" & "," & "05" & ":" & "49 AM" & vbCr & vbLf & "20201121" & "," & "07" & ":" & "13 AM" & vbCr & vbLf & "20201122" & "," & "06" & ":" & "01 AM" & vbCr & vbLf & " " & vbCr & vbLf & "Date" & "," & "ActiveProducts " & vbCr & vbLf & "20201116" & "," & "24" & vbCr & vbLf & "20201117" & "," & "244" & vbCr & vbLf & "20201118" & "," & "245 " & vbCr & vbLf & "20201119" & "," & "24 " & vbCr & vbLf & "20201120" & "," & "249 " & vbCr & vbLf & "20201121" & "," & "250 " & vbCr & vbLf & "20201122" & "," & "250 " & vbCr & vbLf & " " & vbCr & vbLf & "Date" & "," & "ActiveSKUs " & vbCr & vbLf & "20201116" & "," & "137" & vbCr & vbLf & "20201117" & "," & "13" & vbCr & vbLf & "20201118" & "," & "13" & vbCr & vbLf & "20201119" & "," & "1368" & vbCr & vbLf & "20201120" & "," & "13" & vbCr & vbLf & "20201121" & "," & "1381" & vbCr & vbLf & "20201122" & "," & "13" & vbCr & vbLf & " " & vbCr & vbLf & "Date" & "," & "CompletedOrderCount " & vbCr & vbLf & "20201116" & "," & "24" & vbCr & vbLf & "20201117" & "," & "24" & vbCr & vbLf & "20201118" & "," & "3" & vbCr & vbLf & "20201119" & "," & "24" & vbCr & vbLf & "20201120" & "," & "63" & vbCr & vbLf & "20201121" & "," & "69" & vbCr & vbLf & "20201122" & "," & "8" & vbCr & vbLf & "20201123" & "," & "9" & vbCr & vbLf & " " & vbCr & vbLf & "Date" & "," & "PendingOrderCount " & vbCr & vbLf & "20201116" & "," & "18" & vbCr & vbLf & "20201117" & "," & "5405" & vbCr & vbLf & "20201118" & "," & "6114" & vbCr & vbLf & "20201119" & "," & "6" & vbCr & vbLf & "20201120" & "," & "6482" & vbCr & vbLf & "20201121" & "," & "74" & vbCr & vbLf & "20201122" & "," & "128" & vbCr & vbLf & "20201123" & "," & "4" & vbCr & vbLf & " " & vbCr & vbLf

"-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & " " & vbCr & vbLf
"This is a report for last week " & vbCr & vbLf
"-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & " " & vbCr & vbLf
" " & vbCr & vbLf
"Date" & "," & "RunbookBCompletionTime " & vbCr & vbLf
"20201116" & "," & "05" & ":" & "44 AM" & vbCr & vbLf
"20201117" & "," & "05" & ":" & "47 AM" & vbCr & vbLf
"20201118" & "," & "05" & ":" & "39 AM" & vbCr & vbLf
"20201119" & "," & "06" & ":" & "10 AM" & vbCr & vbLf
"20201120" & "," & "05" & ":" & "49 AM" & vbCr & vbLf
"20201121" & "," & "07" & ":" & "13 AM" & vbCr & vbLf
"20201122" & "," & "06" & ":" & "01 AM" & vbCr & vbLf
" " & vbCr & vbLf
"Date" & "," & "ActiveProducts " & vbCr & vbLf
"20201116" & "," & "24" & vbCr & vbLf
"20201117" & "," & "244" & vbCr & vbLf
"20201118" & "," & "245 " & vbCr & vbLf
"20201119" & "," & "24 " & vbCr & vbLf
"20201120" & "," & "249 " & vbCr & vbLf
"20201121" & "," & "250 " & vbCr & vbLf
"20201122" & "," & "250 " & vbCr & vbLf
" " & vbCr & vbLf
"Date" & "," & "ActiveSKUs " & vbCr & vbLf
"20201116" & "," & "137" & vbCr & vbLf
"20201117" & "," & "13" & vbCr & vbLf
"20201118" & "," & "13" & vbCr & vbLf
"20201119" & "," & "1368" & vbCr & vbLf
"20201120" & "," & "13" & vbCr & vbLf
"20201121" & "," & "1381" & vbCr & vbLf
"20201122" & "," & "13" & vbCr & vbLf
" " & vbCr & vbLf
"Date" & "," & "CompletedOrderCount " & vbCr & vbLf
"20201116" & "," & "24" & vbCr & vbLf
"20201117" & "," & "24" & vbCr & vbLf
"20201118" & "," & "3" & vbCr & vbLf
"20201119" & "," & "24" & vbCr & vbLf
"20201120" & "," & "63" & vbCr & vbLf
"20201121" & "," & "69" & vbCr & vbLf
"20201122" & "," & "8" & vbCr & vbLf
"20201123" & "," & "9" & vbCr & vbLf
" " & vbCr & vbLf
"Date" & "," & "PendingOrderCount " & vbCr & vbLf
"20201116" & "," & "18" & vbCr & vbLf
"20201117" & "," & "5405" & vbCr & vbLf
"20201118" & "," & "6114" & vbCr & vbLf
"20201119" & "," & "6" & vbCr & vbLf
"20201120" & "," & "6482" & vbCr & vbLf
"20201121" & "," & "74" & vbCr & vbLf
"20201122" & "," & "128" & vbCr & vbLf
"20201123" & "," & "4" & vbCr & vbLf
" " & vbCr & vbLf

0 "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & " " & vbCr & vbLf
1 "This is a report for last week " & vbCr & vbLf
2 "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & "-" & " " & vbCr & vbLf
3 " " & vbCr & vbLf
4 "Date" & "," & "RunbookBCompletionTime " & vbCr & vbLf
5 "20201116" & "," & "05" & ":" & "44 AM" & vbCr & vbLf
6 "20201117" & "," & "05" & ":" & "47 AM" & vbCr & vbLf
7 "20201118" & "," & "05" & ":" & "39 AM" & vbCr & vbLf
8 "20201119" & "," & "06" & ":" & "10 AM" & vbCr & vbLf
9 "20201120" & "," & "05" & ":" & "49 AM" & vbCr & vbLf
10 "20201121" & "," & "07" & ":" & "13 AM" & vbCr & vbLf
11 "20201122" & "," & "06" & ":" & "01 AM" & vbCr & vbLf
12 " " & vbCr & vbLf
13 "Date" & "," & "ActiveProducts " & vbCr & vbLf
14 "20201116" & "," & "24" & vbCr & vbLf
15 "20201117" & "," & "244" & vbCr & vbLf
16 "20201118" & "," & "245 " & vbCr & vbLf
17 "20201119" & "," & "24 " & vbCr & vbLf
18 "20201120" & "," & "249 " & vbCr & vbLf
19 "20201121" & "," & "250 " & vbCr & vbLf
20 "20201122" & "," & "250 " & vbCr & vbLf
21 " " & vbCr & vbLf
22 "Date" & "," & "ActiveSKUs " & vbCr & vbLf
23 "20201116" & "," & "137" & vbCr & vbLf
24 "20201117" & "," & "13" & vbCr & vbLf
25 "20201118" & "," & "13" & vbCr & vbLf
26 "20201119" & "," & "1368" & vbCr & vbLf
27 "20201120" & "," & "13" & vbCr & vbLf
28 "20201121" & "," & "1381" & vbCr & vbLf
29 "20201122" & "," & "13" & vbCr & vbLf
30 " " & vbCr & vbLf
31 "Date" & "," & "CompletedOrderCount " & vbCr & vbLf
32 "20201116" & "," & "24" & vbCr & vbLf
33 "20201117" & "," & "24" & vbCr & vbLf
34 "20201118" & "," & "3" & vbCr & vbLf
35 "20201119" & "," & "24" & vbCr & vbLf
36 "20201120" & "," & "63" & vbCr & vbLf
37 "20201121" & "," & "69" & vbCr & vbLf
38 "20201122" & "," & "8" & vbCr & vbLf
39 "20201123" & "," & "9" & vbCr & vbLf
40 " " & vbCr & vbLf
41 "Date" & "," & "PendingOrderCount " & vbCr & vbLf
42 "20201116" & "," & "18" & vbCr & vbLf
43 "20201117" & "," & "5405" & vbCr & vbLf
44 "20201118" & "," & "6114" & vbCr & vbLf
45 "20201119" & "," & "6" & vbCr & vbLf
46 "20201120" & "," & "6482" & vbCr & vbLf
47 "20201121" & "," & "74" & vbCr & vbLf
48 "20201122" & "," & "128" & vbCr & vbLf
49 "20201123" & "," & "4" & vbCr & vbLf
50 " " & vbCr & vbLf

http://i.imgur.com/JouNd9P.jpg
https://i.imgur.com/JouNd9P.jpg

Sub LookInAndImportTextStringSample()
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, FlNme As String
Let FlNme = "Sample.txt"
Let PathAndFileName = ThisWorkbook.Path & "\" & FlNme
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
'' What is in this string?
'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile, FlNme)
' We now have the entire text file as a long string, it looks like the conventional vbCr and vbLf are used as line seperators,
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'
' Make an array for the output
Dim arrOut() As Variant: Let arrOut() = ThisWorkbook.Worksheets("Sheet1").Range("B4:AC10").Value
' An array for the Headers in Excel file
Dim ExHdrs() As Variant: Let ExHdrs() = ThisWorkbook.Worksheets("Sheet1").Range("A4:A10").Value
Dim Cnt As Long
Do While Cnt - 1 < UBound(arrRws)
Let Cnt = Cnt + 1 ' For next line
Dim Lne As String: Let Lne = arrRws(Cnt - 1) ' The line text
If Left(Lne, 4) = "Date" Then ' we have arived at a chunk of data
Dim Hdr As String: Let Hdr = Mid(Lne, (InStr(1, Lne, ",", vbBinaryCompare) + 1)) ' this picks out the header in the text string line
Let Hdr = Trim(Hdr) ' the text sample data has an extra space at the end, so this takes it off
Dim ExHdrRw As Variant: Let ExHdrRw = Application.Match(Hdr, ExHdrs(), 0) ' this will be the first dimension ( "row" ) where the data should go in the output array
If IsError(ExHdrRw) Then ' Application.match will give an Excel error if it does not find the matching heading in the Excel worksheet column "A4:A10"
MsgBox prompt:="The header, """ & Hdr & """ , is not in the Excel file"
Exit Sub
Else ' we have a valid header
Do While Trim(arrRws(Cnt)) <> "" And Cnt - 1 < UBound(arrRws) ' ( I am using Trim( ) because some of the "empty" lines actually had a space in them )
Let Cnt = Cnt + 1 ' For next line
Let Lne = arrRws(Cnt - 1) ' The line text
If Left(Lne, 2) = "20" Then ' check we have a dtae entry in the line
Dim Dey As Long: Let Dey = Mid(Lne, 7, 2) ' pick out the day
' We now have the day and the Header row, so we can go about picking out the data and putting the data ijn the corr4ect place in the output array
Dim Tme As String: Let Tme = Mid(Lne, InStr(1, Lne, ",", vbBinaryCompare) + 1) ' this picks out the time shown after the ","
Let arrOut(ExHdrRw, Dey) = Tme
Else
' we do not have a date enty in the line
End If
Loop ' While arrRws(Cnt) <> "" And Cnt - 1 < UBound(arrRws)
End If
Else
' Its a sutuation to keep going down looking for a "Date" in the line text
End If
Loop ' While Cnt < ubound(arrRws)
'
' Finally paste the output array to the worksheet
Let ThisWorkbook.Worksheets("Sheet1").Range("B4:AC10").Value = arrOut()
End Sub

results after running macro , Sub LookInAndImportTextStringSample()
Row\ColQRSTUVWXY
1

216171819202127

3MTWThFSSuMT

45:44 AM5:47 AM5:39 AM6:10 AM5:49 AM7:13 AM6:01 AM4

52424424524249250250

61371313136813138113

7

8

92424324636989

10185405611466482741284

11

See also next post for more detailed results:

DocAElstein

11-27-2020, 12:33 PM

In support of this Thread
https://www.ozgrid.com/forum/index.php?thread/1228586-import-certain-data-from-comma-seperated-text-file-to-excel/&postID=1241623#post1241623

Before
_____ Workbook: Sample excel file.xls ( Using Excel 2007 32 bit )
Row\ColABPQRSTUVWXY
21516171819202127

3SLASuMTWThFSSuMT

4RunbookBCompletionTime6:00AM

5ActiveProductsN/A

6ActiveSKUsN/A

7PendingN/A

8CompletedN/A

9CompletedOrderCountN/A

10PendingOrderCountN/A

11

12

13Active

14
Worksheet: Sheet1
http://i.imgur.com/jrBBlXT.jpg https://i.imgur.com/jrBBlXT.jpg

text file: Sample.txt

----------------------------------------------------
This is a report for last week
----------------------------------------------------

Date,RunbookBCompletionTime
20201116,05:44 AM
20201117,05:47 AM
20201118,05:39 AM
20201119,06:10 AM
20201120,05:49 AM
20201121,07:13 AM
20201122,06:01 AM

Date,ActiveProducts
20201116,24
20201117,244
20201118,245
20201119,24
20201120,249
20201121,250
20201122,250

Date,ActiveSKUs
20201116,137
20201117,13
20201118,13
20201119,1368
20201120,13
20201121,1381
20201122,13

Date,CompletedOrderCount
20201116,24
20201117,24
20201118,3
20201119,24
20201120,63
20201121,69
20201122,8
20201123,9

Date,PendingOrderCount
20201116,18
20201117,5405
20201118,6114
20201119,6
20201120,6482
20201121,74
20201122,128
20201123,4

After runningSub LookInAndImportTextStringSample()
https://i.imgur.com/0m881xs.jpg https://i.imgur.com/0m881xs.jpg
_____ Workbook: Sample excel file.xls ( Using Excel 2007 32 bit )
Row\ColPQRSTUVWXY
21516171819202127

3SuMTWThFSSuMT

405:4405:4705:3906:1005:4907:1306:01

52424424524249250250

61371313136813138113

7

8

92424324636989

10185405611466482741284

11

12
Worksheet: Sheet1

Share ‘Sample excel file.xls’ : https://app.box.com/s/hw4uxwjlm8t8zty17kc07xihq0bfhifs
Share ‘Sample excel file.xlsm’ : https://app.box.com/s/ccmk5sgazueejb4dc0eqw6yex0zhjar2

DocAElstein

11-29-2020, 12:28 PM

Dec 2020-11-29

If I make text file with nothing in it and then after look at the text file with the following macro ..._

' A virgin text file
Sub AVirginTextFile()
' 1 Make a virgin text file
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 & "\" & "NoText.txt" ' CHANGE path TO SUIT
Open PathAndFileName2 For Output As #FileNum2
Dim NoText As String
Print #FileNum2, NoText ' write out entire text file, the file is made if not there
Close #FileNum2
' 2a) Get the text file 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 & "NoText.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
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 'Debug.Print TotalFile
Close #FileNum
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)
End Sub
_... then I will see nothing at all in Notepad, and from my WotchaGot function it will tell me that I have
vbCr & vbLf

If I Let NoText = "x" , and repeat the experiment, I see in notepad .._

x
_.. and my function tells me that I have
"x" & vbCr & vbLf

Here are some more experiments, and the results:
Let NoText = "x" & vbCr & "x"
"x" & vbCr & "x" & vbCr & vbLf

xx

Let NoText = "x" & vbLf & "x"
"x" & vbLf & "x" & vbCr & vbLf

xx

Let NoText = "x" & vbCr & vbLf & "x"
"x" & vbCr & vbLf & "x" & vbCr & vbLf

x
x

Let NoText = "x" & vbLf & vbCr & "x"
"x" & vbLf & vbCr & "x" & vbCr & vbLf

xx

If I repeat the experiment using extension .csv instead of .txt everywhere in my macro, then the results are identical.
So it appears that notepad only recognises the pair vbCr & vbLf as a new line

( Note: if I open any of the files ( .txt or .csv ) in Excel , using any default settings, then for the case of the vbLf or the vbCr or the pair vbCr & vbLf then Excel always seems to add a line and I see
_____ Workbook: NoText.txt ( Using Excel 2007 32 bit )
Row\Col
A

1x

2x
Worksheet: NoText
_____ Workbook: NoText.csv ( Using Excel 2007 32 bit )
Row\Col
A

1x

2x
Worksheet: NoText

For the case of using vbLf & vbCr, using the default settings opening in Excel the .txt file also gives the same result, but strangely for the .csv file we see an extra line
_____ Workbook: NoText.csv ( Using Excel 2007 32 bit )
Row\Col
A

1x

2

3x
Worksheet: NoText

DocAElstein

02-17-2021, 06:53 PM

post for later use

DocAElstein

02-17-2021, 06:53 PM

Following on, and in support of, these Forum Posts:
http://www.eileenslounge.com/viewtopic.php?p=292266#p292266
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776

In one of those Posts we figured out how to get a text file 3 column list of the service´s Name , DisplayName and StartType, using a single PowerShell script commandlet.
Here I want to automate that a bit.
First I reduced the text file a bit to this

Name DisplayName StartType
---- ----------- ---------
AarSvc_72b48 Agent Activation Runtime_72b48 Manual
AJRouter AllJoyn-Routerdienst Manual
ALG Gatewaydienst auf Anwendungsebene Manual
ApHidMonitorService AlpsAlpine SMBus Monitor Service Automatic

The I took a look using this

Sub LookInFirstBitOfTextString() ' https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
' Get the text file 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 & "test4lines.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
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 'Debug.Print TotalFile
Close #FileNum
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)
End Sub
That produced a total strong with rather a lot of CHR(0)s
https://i.postimg.cc/t43HCQr9/Rather-a-lot-of-Chr-0-s.jpg https://i.postimg.cc/LJ8WN7KW/Rather-a-lot-of-Chr-0-s.jpg (https://postimg.cc/LJ8WN7KW)
So I modified the code a bit to take them out, since I am not too interested in them, and I am not sure what they might do. This is a mod I would most likely want to do permanently, and initially now, I would like to do it as its obscuring the main stuff I want to see: That is easily done with TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare)
After that it looks a bit better.
I have 4 characters at the start, Chr(255) Chr(254) vbCr vbLf , which I can probably do away with as well, same again: TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf , "", 1, 1, vbBinaryCompare) ( Altertnativel we can just consider the Chr(255) & Chr(254) as the first line and disregard that later.)
The title line I could probably do away with as well, as I know what it is, or rather I know the 3 header words that I am interested in, as well as the order that they come in, "Name DisplayName StartType"
and
I can forget about the second line as well, as it seems to be just some dashes used to underline the headers.
So I will be disregarding the first 2 ( or 3 ) lines

The line separator is as expected, vbCr & vbLf . ( There are few extra trailing ones. I can leave those, as I don’t think they will confuse much of my further plans for manipulating the total string

My plan will be to split by the vbCr & vbLf to get 1 dimensional array or the rows.
The separator just seems to be a lot of spaces. As I have three text things that I want on each row, and they appear to have no spaces in them, I can do a simple bit of text manipulation to get at those three words at each row.
After that, putting each word in a “row” of a 2 D array of 3 “columns” will be convenient to then paste out in an Excel worksheet

This does all that

' make array for output
Dim arrOut() As String: ReDim arrOut(1 To UBound(arrRws()) - 2, 1 To 3) ' we are ignoring the first 3 lines. The UBound of the 1 dimensional array is already 1 less then the lines we need because a 1 dimensional array starts at 0
Dim Cnt As Long
For Cnt = 1 To UBound(arrRws()) - 2
If arrRws(Cnt + 2) = "" Then
' This should occur at the last empty rows, so we could consider jumping out of the loop here
Else
' time to split the line string
Dim Pos1 As Long: Let Pos1 = InStr(1, arrRws(Cnt + 2), " ", vbBinaryCompare)
Dim Nme As String: Let Nme = Left(arrRws(Cnt + 2), Pos1 - 1)
Dim Pos3 As Long: Let Pos3 = Len(arrRws(Cnt + 2)) - InStrRev(arrRws(Cnt + 2), " ", -1, vbBinaryCompare)
Dim StrtTyp As String: Let StrtTyp = Right(arrRws(Cnt + 2), Pos3)
Dim DispNme As String: Let DispNme = Replace(arrRws(Cnt + 2), Nme, "", 1, -1, vbBinaryCompare)
Let DispNme = Replace(DispNme, StrtTyp, "", 1, -1, vbBinaryCompare)
Let DispNme = Trim(DispNme)
' fill the array for output
Let arrOut(Cnt, 1) = Nme: arrOut(Cnt, 2) = DispNme: arrOut(Cnt, 3) = StrtTyp
End If

Next Cnt

The rest is just pasting that arrOut() directly in a spreadsheet

DocAElstein

02-17-2021, 06:54 PM

later...

DocAElstein

02-17-2021, 06:54 PM

post for later use ... later

DocAElstein

02-17-2021, 06:54 PM

post ti get URL

DocAElstein

02-17-2021, 06:55 PM

later ,,,.........

DocAElstein

02-17-2021, 06:55 PM

later -----------

DocAElstein

02-17-2021, 06:55 PM

post for later...

DocAElstein

02-17-2021, 06:55 PM

later ...

DocAElstein

02-17-2021, 06:56 PM

In support of this post
https://excelfox.com/forum/showthread.php/2710-Need-help-to-convert-Excel-data-to-XML?p=15355#post15355

_____ Workbook: Sample excel file.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1Entity IDdaymonthyeartime
1<-- row number

2
700
19
2
2021
08:00
2

3
700
19
2
2021
08:30
3

4
700
20
2
2021
09:00
4

5
701
19
2
2021
09:30
5

6
6

7
2
3
4
5<-- column number

8

9Lr=5

10arrIn()=Range("A1:E5").Value12
3
4
5
6

11
1Entity IDdaymonthyeartime

12
2
700
19
2
2021
08:00

13
3
700
19
2
2021
08:30

14
4
700
20
2
2021
09:00

15
5
701
19
2
2021
09:30

16
6

17Example: arrIn(5, 1) = 701
Worksheet: Sheet1

text file output

<forecast>
<Entity>700</Entity>
<data>
<date>
<day>19/<day>
<month>2</month>
<year>2021</year>
</date>
<time>08:00</time>
<time>08:30</time>
</data>
<data>
<date>
<day>20/<day>
<month>2</month>
<year>2021</year>
</date>
<time>09:00</time>
</data>
</forcast>
<forecast>
<Entity>701</Entity>
<data>
<date>
<day>19/<day>
<month>2</month>
<year>2021</year>
</date>
<time>09:30</time>
</data>
</forcast>

Option Explicit
'
Sub ExcelToXML()
Rem 1 worksheets data info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = Ws1.Range("A" & Rows.Count & "").End(xlUp).Row
Dim arrRng() As Variant: Let arrRng() = Ws1.Range("A1:E" & Lr + 1 & "").Value ' +1 is a bodge to help me not get errors when checking 1 row above my data
Rem 2 Do it
Dim TotalFile As String
Dim Rw As Long: Let Rw = 2 ' Main row count
' #STEP 1 Start
Do While Rw <= Lr ' This keeps us going as long as data is there
Let TotalFile = TotalFile & "<forecast>" & vbCr & vbLf & "<Entity>" & arrRng(Rw, 1) & "</Entity>" & vbCr & vbLf: Debug.Print TotalFile
' # STEP 2 start
Let TotalFile = TotalFile & "<data>" & vbCr & vbLf & "<date>" & vbCr & vbLf & "<day>" & arrRng(Rw, 2) & "/<day>" & vbCr & vbLf & "<month>" & arrRng(Rw, 3) & "</month>" & vbCr & vbLf & "<year>" & arrRng(Rw, 4) & "</year>" & vbCr & vbLf & "</date>" & vbCr & vbLf & "<time>" & Format(arrRng(Rw, 5), "hh" & ":" & "mm") & "</time>" & vbCr & vbLf: Debug.Print TotalFile
' #STEP 3 START
' Check if Entity ID in first row = Entity ID in 2nd row and date in first row = date in 2nd row then repeat STEP 3 for 2nd row and so on
Do While Rw + 1 <= Lr And arrRng(Rw, 1) = arrRng(Rw + 1, 1) And arrRng(Rw, 2) = arrRng(Rw + 1, 2)
Let TotalFile = TotalFile & "<time>" & Format(arrRng(Rw + 1, 5), "hh" & ":" & "mm") & "</time>" & vbCr & vbLf: Debug.Print TotalFile
Let Rw = Rw + 1 ' This brings us to the line we just filled in
Loop
Let TotalFile = TotalFile & "</data>" & vbCr & vbLf: Debug.Print TotalFile

' Chect if Entity ID in first row = Entity ID in 2nd row and date in first row not equals to date in 2nd row then repeat STEP 2 for 2nd row and so on
Do While Rw + 1 <= Lr And arrRng(Rw, 1) = arrRng(Rw + 1, 1) ' And Not arrRng(Rw, 2) = arrRng(Rw + 1, 2)
Let TotalFile = TotalFile & "<data>" & vbCr & vbLf & "<date>" & vbCr & vbLf & "<day>" & arrRng(Rw + 1, 2) & "/<day>" & vbCr & vbLf & "<month>" & arrRng(Rw + 1, 3) & "</month>" & vbCr & vbLf & "<year>" & arrRng(Rw + 1, 4) & "</year>" & vbCr & vbLf & "</date>" & vbCr & vbLf & "<time>" & Format(arrRng(Rw + 1, 5), "hh" & ":" & "mm") & "</time>" & vbCr & vbLf: Debug.Print TotalFile
Let Rw = Rw + 1 ' This brings us to the line we just filled in
Loop
Let TotalFile = TotalFile & "</data>" & vbCr & vbLf: Debug.Print TotalFile

' #STEP 3 END
' STEP 2 END
Let TotalFile = TotalFile & "</forcast>" & vbCr & vbLf: Debug.Print TotalFile
Let Rw = Rw + 1 ' ' This brings us to the next line
' STEP 1 END
Loop ' While Rw <= Lr

Let TotalFile = Replace(TotalFile, "</data>" & vbCr & vbLf & "</data>" & vbCr & vbLf, "</data>" & vbCr & vbLf, 1, -1, vbBinaryCompare): Debug.Print TotalFile ' I end up with a double "</data>" & vbCr & vbLf
Rem 3 Make text file
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 & "\" & "XML_Stuff.txt" ' ' CHANGE TO SUIT ' Will be made if not there
Open PathAndFileName2 For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2

End Sub

' <forecast> ' #STEP 1 Start Print #intFile, "<Forecast>"
' <Entity>700</Entity> ' #STEP 1 Start Print #intFile, "<Entity>" & Entity ID & "</Entity>"
' <data> ' #STEP 2 Start Print #intFile, "<Data>"
' <date> ' #STEP 2 Start Print #intFile, "<date>"
' <day>19</day> ' #STEP 2 Start Print #intFile, "<day>" & day &
' <month>2</month> ' #STEP 2 Start "</day><month>" & month & "</month>
' <year>2021</year> ' #STEP 2 Start <year>" & yeear & "</year>"
' </date> ' #STEP 2 Start </date>"
' <time>8:00</time> ' #STEP 3 START Print #intFile, "<time>" & time & "</time>"
' Check if Entity ID in first row = Entity ID in 2nd row
' and date in first row = date in 2nd row then
' <time>8:30</time> ' repeat STEP 3 for 2nd row and so on
' </data> ' #STEP 3 END
' Check if Entity ID in first row = Entity ID in 2nd row
' and date in first row IS NOT = date in 2nd row then'
' repeat STEP ??3?? 2 for 2nd row and so on
' <data>
' <date>
' <day>20</day>
' <month>2</month>
' <year>2021</year>
' </date>
' <time> ??8:00?? 9.00 </time>
' </data>
' </forecast> ' STEP 2 END Print #intFile, "</forecast>"

' If Entity ID is not same as in previous row repeat STEP 1
'
' <forecast>
' <Entity>701</Entity>
' <data>
' <date>
' <day>19</day>
' <month>2</month>
' <year>2021</year>
' </date>
' <time>9:30</time>
' </data>
' </forecast>
' <forecast>

DocAElstein

02-17-2021, 06:56 PM

In support of this post
https://excelfox.com/forum/showthread.php/2710-Need-help-to-convert-Excel-data-to-XML?p=15355#post15355

_____ Workbook: Sample excel file.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1Entity IDdaymonthyeartime
1<-- row number

2
700
19
2
2021
08:00
2

3
700
19
2
2021
08:30
3

4
700
20
2
2021
09:00
4

5
701
19
2
2021
09:30
5

6
6

7
2
3
4
5<-- column number

8

9Lr=5

10arrIn()=Range("A1:E5").Value12
3
4
5
6

11
1Entity IDdaymonthyeartime

12
2
700
19
2
2021
08:00

13
3
700
19
2
2021
08:30

14
4
700
20
2
2021
09:00

15
5
701
19
2
2021
09:30

16
6

17Example: arrIn(5, 1) = 701
Worksheet: Sheet1

text file output

<forecast>
<Entity>700</Entity>
<data>
<date>
<day>19/<day>
<month>2</month>
<year>2021</year>
</date>
<time>08:00</time>
<time>08:30</time>
</data>
<data>
<date>
<day>20/<day>
<month>2</month>
<year>2021</year>
</date>
<time>09:00</time>
</data>
</forcast>
<forecast>
<Entity>701</Entity>
<data>
<date>
<day>19/<day>
<month>2</month>
<year>2021</year>
</date>
<time>09:30</time>
</data>
</forcast>

Option Explicit
'
Sub ExcelToXML()
Rem 1 worksheets data info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = Ws1.Range("A" & Rows.Count & "").End(xlUp).Row
Dim arrRng() As Variant: Let arrRng() = Ws1.Range("A1:E" & Lr + 1 & "").Value ' +1 is a bodge to help me not get errors when checking 1 row above my data
Rem 2 Do it
Dim TotalFile As String
Dim Rw As Long: Let Rw = 2 ' Main row count
' #STEP 1 Start
Do While Rw <= Lr ' This keeps us going as long as data is there
Let TotalFile = TotalFile & "<forecast>" & vbCr & vbLf & "<Entity>" & arrRng(Rw, 1) & "</Entity>" & vbCr & vbLf: Debug.Print TotalFile
' # STEP 2 start
Let TotalFile = TotalFile & "<data>" & vbCr & vbLf & "<date>" & vbCr & vbLf & "<day>" & arrRng(Rw, 2) & "/<day>" & vbCr & vbLf & "<month>" & arrRng(Rw, 3) & "</month>" & vbCr & vbLf & "<year>" & arrRng(Rw, 4) & "</year>" & vbCr & vbLf & "</date>" & vbCr & vbLf & "<time>" & Format(arrRng(Rw, 5), "hh" & ":" & "mm") & "</time>" & vbCr & vbLf: Debug.Print TotalFile
' #STEP 3 START
' Check if Entity ID in first row = Entity ID in 2nd row and date in first row = date in 2nd row then repeat STEP 3 for 2nd row and so on
Do While Rw + 1 <= Lr And arrRng(Rw, 1) = arrRng(Rw + 1, 1) And arrRng(Rw, 2) = arrRng(Rw + 1, 2)
Let TotalFile = TotalFile & "<time>" & Format(arrRng(Rw + 1, 5), "hh" & ":" & "mm") & "</time>" & vbCr & vbLf: Debug.Print TotalFile
Let Rw = Rw + 1 ' This brings us to the line we just filled in
Loop
Let TotalFile = TotalFile & "</data>" & vbCr & vbLf: Debug.Print TotalFile

' Chect if Entity ID in first row = Entity ID in 2nd row and date in first row not equals to date in 2nd row then repeat STEP 2 for 2nd row and so on
Do While Rw + 1 <= Lr And arrRng(Rw, 1) = arrRng(Rw + 1, 1) ' And Not arrRng(Rw, 2) = arrRng(Rw + 1, 2)
Let TotalFile = TotalFile & "<data>" & vbCr & vbLf & "<date>" & vbCr & vbLf & "<day>" & arrRng(Rw + 1, 2) & "/<day>" & vbCr & vbLf & "<month>" & arrRng(Rw + 1, 3) & "</month>" & vbCr & vbLf & "<year>" & arrRng(Rw + 1, 4) & "</year>" & vbCr & vbLf & "</date>" & vbCr & vbLf & "<time>" & Format(arrRng(Rw + 1, 5), "hh" & ":" & "mm") & "</time>" & vbCr & vbLf: Debug.Print TotalFile
Let Rw = Rw + 1 ' This brings us to the line we just filled in
Loop
Let TotalFile = TotalFile & "</data>" & vbCr & vbLf: Debug.Print TotalFile

' #STEP 3 END
' STEP 2 END
Let TotalFile = TotalFile & "</forcast>" & vbCr & vbLf: Debug.Print TotalFile
Let Rw = Rw + 1 ' ' This brings us to the next line
' STEP 1 END
Loop ' While Rw <= Lr

Let TotalFile = Replace(TotalFile, "</data>" & vbCr & vbLf & "</data>" & vbCr & vbLf, "</data>" & vbCr & vbLf, 1, -1, vbBinaryCompare): Debug.Print TotalFile ' I end up with a double "</data>" & vbCr & vbLf
Rem 3 Make text file
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 & "\" & "XML_Stuff.txt" ' ' CHANGE TO SUIT ' Will be made if not there
Open PathAndFileName2 For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2

End Sub

' <forecast> ' #STEP 1 Start Print #intFile, "<Forecast>"
' <Entity>700</Entity> ' #STEP 1 Start Print #intFile, "<Entity>" & Entity ID & "</Entity>"
' <data> ' #STEP 2 Start Print #intFile, "<Data>"
' <date> ' #STEP 2 Start Print #intFile, "<date>"
' <day>19</day> ' #STEP 2 Start Print #intFile, "<day>" & day &
' <month>2</month> ' #STEP 2 Start "</day><month>" & month & "</month>
' <year>2021</year> ' #STEP 2 Start <year>" & yeear & "</year>"
' </date> ' #STEP 2 Start </date>"
' <time>8:00</time> ' #STEP 3 START Print #intFile, "<time>" & time & "</time>"
' Check if Entity ID in first row = Entity ID in 2nd row
' and date in first row = date in 2nd row then
' <time>8:30</time> ' repeat STEP 3 for 2nd row and so on
' </data> ' #STEP 3 END
' Check if Entity ID in first row = Entity ID in 2nd row
' and date in first row IS NOT = date in 2nd row then'
' repeat STEP ??3?? 2 for 2nd row and so on
' <data>
' <date>
' <day>20</day>
' <month>2</month>
' <year>2021</year>
' </date>
' <time> ??8:00?? 9.00 </time>
' </data>
' </forecast> ' STEP 2 END Print #intFile, "</forecast>"

' If Entity ID is not same as in previous row repeat STEP 1
'
' <forecast>
' <Entity>701</Entity>
' <data>
' <date>
' <day>19</day>
' <month>2</month>
' <year>2021</year>
' </date>
' <time>9:30</time>
' </data>
' </forecast>
' <forecast>

DocAElstein

08-17-2021, 11:50 PM

Test csv file upload ( this post was moved from https://excelfox.com/forum/showthread.php/2759-Test-csv-file-upload?p=15594#post15594
Its new link is https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15594&viewfull=1#post15594
Originally it was referrenced ( linked via URL ) here https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15596&viewfull=1#post15596 https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15596&viewfull=1#post15596 )

DocAElstein

08-17-2021, 11:50 PM

Test csv file upload ( this post was moved from https://excelfox.com/forum/showthread.php/2759-Test-csv-file-upload?p=15594#post15594
Its new link is https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15594&viewfull=1#post15594
Originally it was referrenced ( linked via URL ) here https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15596&viewfull=1#post15596 https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15596&viewfull=1#post15596 )

DocAElstein

08-18-2021, 10:36 AM

Post for later use, to get URL now

DocAElstein

08-18-2021, 10:36 AM

Post for later use, to get URL now

DocAElstein

08-18-2021, 10:52 AM

Some notes in support of these Theads and posts in main forum
https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated

Run-time error 1004 when trying to resize a multi area range object
https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597
https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
apvtrn.csv - first 7 of 9 lines

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0004918,PY,,,2021-04-01,,749-3,,-240.74,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,JAN 16-MAR 17-2021,2021-04-08,2021-05-08,1100-23,0,"2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005064,PY,,,2021-05-06,,769-1,,"-2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APRIL 01-12-2021,2021-05-10,2021-06-09,1135-7,0,262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005260,PY,,,2021-06-24,,801-3,,"-1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 10:52 AM

Some notes in support of these Theads and posts in main forum
https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated

Run-time error 1004 when trying to resize a multi area range object
https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597
https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15586&viewfull=1#post15586
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
apvtrn.csv - first 7 of 9 lines

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0004918,PY,,,2021-04-01,,749-3,,-240.74,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,JAN 16-MAR 17-2021,2021-04-08,2021-05-08,1100-23,0,"2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005064,PY,,,2021-05-06,,769-1,,"-2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APRIL 01-12-2021,2021-05-10,2021-06-09,1135-7,0,262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005260,PY,,,2021-06-24,,801-3,,"-1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 11:24 AM

( this is post 35 15601 , it was used to copy to get post 36 below )

continued from last post

https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597
apvtrn.csv - last 2 of 9 lines

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 13-JUN 10-2021,2021-07-08,2021-08-07,1187-25,0,196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005453,PY,,,2021-08-05,,834-1,,-196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 11:24 AM

Post #36 15604 ( copied originally from post 35, then edited as a way of getting a post here )

continued from last post

This is how the text file from the last 2 post opens in my Excel
_____ Workbook: apvtrn.csv ( Using Excel 2007 32 bit )
Row\ColDIDJDKDLDMDNDODPDQ
1PY00000000000000004918PY
04-01-2021749-3
-240.74

2
4.00E+11INJAN 16-MAR 17-2021
04-08-2021
05-08-20211100-23

2,371.66

3PY00000000000000005064PY
05-06-2021769-1
-2,371.66

4
4.00E+11INAPRIL 01-12-2021
05-10-2021
06-09-20211135-7

262.8

5PY00000000000000005149PY
05-27-2021784-7
-262.8

6
4.00E+11INAPR 01 - MAY 18- 2021
06-08-2021
07-08-20211168-2

1,864.35

7PY00000000000000005260PY
06-24-2021801-3
-1,864.35

8
4.00E+11INAPR 13-JUN 10-2021
07-08-2021
08-07-20211187-25

196.23

9PY00000000000000005453PY
08-05-2021834-1
-196.23
Worksheet: apvtrn

_.. The OP appears unable to explain what he wants, and he probably doesn't know or can hardly speak a word of English.. never mind ... it isn't the fucking first time, and i doubt it will be the last, onward! based on seeing this a lot form the OP , Set rngDst = wkbDst.Worksheets("STATEMENT").Range("A17:C17, E17") , as well as a screenshots he gave,
https://i.imgur.com/VtfbGD2.jpg https://i.imgur.com/VtfbGD2.jpg https://i.imgur.com/W0qJZCN.png https://i.imgur.com/W0qJZCN.png 3603 3604
I am taking a guess that somehow, some of the data above needs to find its way somewhere in the general area shown below
_____ Workbook: VENDOR STATEMENT.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
15Invoice DateInvoice #Invoice Due
DateA/CInvoice $
+

16Balance brought forward

17

18

19
Worksheet: STATEMENT

-.. and from seeing this... For Each Col In Array("DM", "DI", "DN", "DQ") , I will take a guess we can make these relations
DM – A ( date )
DI – B ( big number )
DN – C ( date )

DQ – E ( a number that might be something to do with money )

DocAElstein

08-18-2021, 11:24 AM

In Excel columns I have the URLs, and I copy them
Then I look at what is in the clipboard with the aim of adding enough BB Code URL tags

This is what two links look like

"https" & ":" & "/" & "/" & "www" & "." & "youtube" & "." & "com" & "/" & "watch" & "?" & "v" & "=" & "pGcerfVqYyU" & "&" & "lc" & "=" & "UgwYnetS3HRljX9vOLx4AaABAg" & "." & "94UVSldHOOy9VDJUb" & "_" & "mRBH" & vbCr & vbLf & "https" & ":" & "/" & "/" & "www" & "." & "youtube" & "." & "com" & "/" & "watch" & "?" & "v" & "=" & "pGcerfVqYyU" & "&" & "lc" & "=" & "UgzCtsi4abaxZnZJjZR4AaABAg" & vbCr & vbLf

Fortunately, no surprises, so we just need to add the BB Code URL tags in some convenient way. First thought is to replace the vbCr & vbLf with [/url] & vbCr & vbLf and replace the http with ][/B] & http
The we put the modified string back in the clipboard

Option Explicit
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA/page5
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16480&viewfull=1#post16480
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA/page5#post16480
Sub CopyExcelColumnSpamURL()
Selection.Copy ' This will put it in the clipboard

'Dim objCliCodeCopied As DataObject '**Early Binding. This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
' Set objCliCodeCopied = New DataObject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK. https://web.archive.org/web/20140610055224/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
' ( or instead of those two lines Dim obj As New DataObject ). or next two lines are.....Late Binding equivalent'
Dim objCli As Object ' Late Binding equivalent' If you declare a variable as Object, you are late binding it. https://web.archive.org/web/20141119223828/http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
Set objCli = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' https://web.archive.org/web/20140610055224/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objCli.GetFromClipboard 'All that is in the Clipboard goes in this Data Object initial instance of the Class
Dim SpamURLs As String ' String varable to take the moodified code. This can be very long, like my cock
Let SpamURLs = objCli.GetText() 'retrieve the text in the initial instance of the Class. ( In this case the original code modifies to have code lines )
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(SpamURLs)

Let SpamURLs = Replace(SpamURLs, vbCr & vbLf, "" & vbCr & vbLf, 1, -1, vbBinaryCompare)
Let SpamURLs = Replace(SpamURLs, "http", "[uRl]http", 1, -1, vbBinaryCompare)

' Make a data Object to put back in clipboard. This a Another Object from class just to demo, could have used the first
'Dim objDatCliBackIn As DataObject
' Set objDatCliBackIn = New DataObject 'Set to a new Instance ( Blue Print ) of dataobject
Dim objDatCliBackIn As Object
Set objDatCliBackIn = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDatCliBackIn.SetText "Alan Spam Tests" & vbCr & vbLf & SpamURLs 'Make Data object's text equal to the long string of the modified code
objDatCliBackIn.PutInClipboard 'Place current Data object into the Clipboard, effectivelly putting its text, which is oue final code in the Clipcoard
End Sub

DocAElstein

08-18-2021, 11:24 AM

Post #36 15604 ( copied originally from post 35, then edited as a way of getting a post here )

continued from last post

This is how the text file from the last 2 post opens in my Excel
_____ Workbook: apvtrn.csv ( Using Excel 2007 32 bit )
Row\ColDIDJDKDLDMDNDODPDQ
1PY00000000000000004918PY
04-01-2021749-3
-240.74

2
4.00E+11INJAN 16-MAR 17-2021
04-08-2021
05-08-20211100-23

2,371.66

3PY00000000000000005064PY
05-06-2021769-1
-2,371.66

4
4.00E+11INAPRIL 01-12-2021
05-10-2021
06-09-20211135-7

262.8

5PY00000000000000005149PY
05-27-2021784-7
-262.8

6
4.00E+11INAPR 01 - MAY 18- 2021
06-08-2021
07-08-20211168-2

1,864.35

7PY00000000000000005260PY
06-24-2021801-3
-1,864.35

8
4.00E+11INAPR 13-JUN 10-2021
07-08-2021
08-07-20211187-25

196.23

9PY00000000000000005453PY
08-05-2021834-1
-196.23
Worksheet: apvtrn

_.. The OP appears unable to explain what he wants, and he probably doesn't know or can hardly speak a word of English.. never mind ... it isn't the fucking first time, and i doubt it will be the last, onward! based on seeing this a lot form the OP , Set rngDst = wkbDst.Worksheets("STATEMENT").Range("A17:C17, E17") , as well as a screenshots he gave,
https://i.imgur.com/VtfbGD2.jpg https://i.imgur.com/VtfbGD2.jpg https://i.imgur.com/W0qJZCN.png https://i.imgur.com/W0qJZCN.png 3603 3604
I am taking a guess that somehow, some of the data above needs to find its way somewhere in the general area shown below
_____ Workbook: VENDOR STATEMENT.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
15Invoice DateInvoice #Invoice Due
DateA/CInvoice $
+

16Balance brought forward

17

18

19
Worksheet: STATEMENT

-.. and from seeing this... For Each Col In Array("DM", "DI", "DN", "DQ") , I will take a guess we can make these relations
DM – A ( date )
DI – B ( big number )
DN – C ( date )

DQ – E ( a number that might be something to do with money )

DocAElstein

08-18-2021, 11:24 AM

( this is post 35 15601 , it was used to copy to get post 36 below )

continued from last post

https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597 https://excelfox.com/forum/showthread.php/2757-Run-time-error-1004-when-trying-to-resize-a-multi-area-range-object?p=15597&viewfull=1#post15597
apvtrn.csv - last 2 of 9 lines

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 13-JUN 10-2021,2021-07-08,2021-08-07,1187-25,0,196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005453,PY,,,2021-08-05,,834-1,,-196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 11:24 AM

Post #36 15604 ( copied originally from post 35, then edited as a way of getting a post here )

continued from last post

This is how the text file from the last 2 post opens in my Excel
_____ Workbook: apvtrn.csv ( Using Excel 2007 32 bit )
Row\ColDIDJDKDLDMDNDODPDQ
1PY00000000000000004918PY
04-01-2021749-3
-240.74

2
4.00E+11INJAN 16-MAR 17-2021
04-08-2021
05-08-20211100-23

2,371.66

3PY00000000000000005064PY
05-06-2021769-1
-2,371.66

4
4.00E+11INAPRIL 01-12-2021
05-10-2021
06-09-20211135-7

262.8

5PY00000000000000005149PY
05-27-2021784-7
-262.8

6
4.00E+11INAPR 01 - MAY 18- 2021
06-08-2021
07-08-20211168-2

1,864.35

7PY00000000000000005260PY
06-24-2021801-3
-1,864.35

8
4.00E+11INAPR 13-JUN 10-2021
07-08-2021
08-07-20211187-25

196.23

9PY00000000000000005453PY
08-05-2021834-1
-196.23
Worksheet: apvtrn

_.. The OP appears unable to explain what he wants, and he probably doesn't know or can hardly speak a word of English.. never mind ... it isn't the fucking first time, and i doubt it will be the last, onward! based on seeing this a lot form the OP , Set rngDst = wkbDst.Worksheets("STATEMENT").Range("A17:C17, E17") , as well as a screenshots he gave,
https://i.imgur.com/VtfbGD2.jpg https://i.imgur.com/VtfbGD2.jpg https://i.imgur.com/W0qJZCN.png https://i.imgur.com/W0qJZCN.png 3603 3604
I am taking a guess that somehow, some of the data above needs to find its way somewhere in the general area shown below
_____ Workbook: VENDOR STATEMENT.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
15Invoice DateInvoice #Invoice Due
DateA/CInvoice $
+

16Balance brought forward

17

18

19
Worksheet: STATEMENT

-.. and from seeing this... For Each Col In Array("DM", "DI", "DN", "DQ") , I will take a guess we can make these relations
DM – A ( date )
DI – B ( big number )
DN – C ( date )

DQ – E ( a number that might be something to do with money )

DocAElstein

08-18-2021, 11:35 AM

( Post #37 15602 )

formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated [/size]

continued from last post

apvtrn.csv - first 6 lines of 9 lines in Text File supplied here https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0004918,PY,,,2021-04-01,,749-3,,-240.74,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,JAN 16-MAR 17-2021,2021-04-08,2021-05-08,1100-23,0,"2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005064,PY,,,2021-05-06,,769-1,,"-2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APRIL 01-12-2021,2021-05-10,2021-06-09,1135-7,0,262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 11:35 AM

( Post #37 15602 )

formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated [/size]

continued from last post

apvtrn.csv - first 6 lines of 9 lines in Text File supplied here https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0004918,PY,,,2021-04-01,,749-3,,-240.74,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,JAN 16-MAR 17-2021,2021-04-08,2021-05-08,1100-23,0,"2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005064,PY,,,2021-05-06,,769-1,,"-2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APRIL 01-12-2021,2021-05-10,2021-06-09,1135-7,0,262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 11:35 AM

( Post #37 15602 )

formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated [/size]

continued from last post

apvtrn.csv - first 6 lines of 9 lines in Text File supplied here https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0004918,PY,,,2021-04-01,,749-3,,-240.74,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,JAN 16-MAR 17-2021,2021-04-08,2021-05-08,1100-23,0,"2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005064,PY,,,2021-05-06,,769-1,,"-2,371.66",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APRIL 01-12-2021,2021-05-10,2021-06-09,1135-7,0,262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

continued in next post

DocAElstein

08-18-2021, 11:43 AM

( Post #38 15603 )

contunued from last post

last 5 of nine lines in apvtrn.csv as supplied for formatting number in csv file import. Number being rounded / decimal places truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005260,PY,,,2021-06-24,,801-3,,"-1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 13-JUN 10-2021,2021-07-08,2021-08-07,1187-25,0,196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005453,PY,,,2021-08-05,,834-1,,-196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

DocAElstein

08-18-2021, 11:43 AM

( Post #38 15603 )

contunued from last post

last 5 of nine lines in apvtrn.csv as supplied for formatting number in csv file import. Number being rounded / decimal places truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005260,PY,,,2021-06-24,,801-3,,"-1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 13-JUN 10-2021,2021-07-08,2021-08-07,1187-25,0,196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005453,PY,,,2021-08-05,,834-1,,-196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

DocAElstein

08-18-2021, 11:43 AM

( Post #38 15603 )

contunued from last post

last 5 of nine lines in apvtrn.csv as supplied for formatting number in csv file import. Number being rounded / decimal places truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598
https://excelfox.com/forum/showthread.php/2758-formatting-number-in-csv-file-import-Number-being-rounded-decimnal-places-truncated?p=15598&viewfull=1#post15598

2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005149,PY,,,2021-05-27,,784-7,,-262.8,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 01 - MAY 18- 2021,2021-06-08,2021-07-08,1168-2,0,"1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005260,PY,,,2021-06-24,,801-3,,"-1,864.35",0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,4.00003E+11,IN, ,APR 13-JUN 10-2021,2021-07-08,2021-08-07,1187-25,0,196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed
2021-08-17 10:56:40AM,Navigata Communications Limited,Page 1,A/P Vendor Transactions (APVTRN01),From Vendor Number,[100045] To [100045],From Vendor Group,[VCAD] To [VEFT],,,,,Sort Vendors By,[Vendor Name],,,,,,,From Document Date,[2021-04-01] To [2021-08-17],Session Date,[2021-08-17],Report Format,[Vendor Transactions by Document Date],Transaction Types,"[Invoice, Credit Note, Prepayment, Payment]",Include Contact/Phone/Credit Limit,[No],Include Space For Comments,[No],Include Zero-Balance Vendors,[Yes],Include Transaction Type Totals,[No],Show Applied Details,[No],Show Fully Paid Transactions,[Yes],Sort Transactions by Transaction Type,[No],Print Amounts In,[Vendor Currency],,,,,,,,,,,,,,,,,,Vendor Number/Name/,,Batch-,Days,Transaction,Document Number/Type,Order Number,PO Number,Doc. Date,Due Date or Check Number,Entry,Over,Amount,Balance,,,,,,,,,100045,BC Hydro (1500 0415 081) consolidated account,,,,,,,,,,,,,,,,,,,,,,,,,,,,PY0000000000000 0005453,PY,,,2021-08-05,,834-1,,-196.23,0,Vendor Total: ,CAD,-240.74,0,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,CR: Credit Note DB: Debit Note IN: Invoice IT: Interest Charge PI: Prepayment MC: Miscellaneous Payment,AD: Adjustment CF: Applied Credit (from) CT: Applied Credit (to) DF: Applied Debit (from) DT: Applied Debit (to) ,ED: Earned Discount Taken GL: Gain or Loss (multicurrency ledgers) PY: Payment RD: Rounding,,1 vendor printed,1 vendor name record printed

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

08-18-2021, 03:29 PM

jjhgjhghjhjg

DocAElstein

02-08-2022, 09:32 PM

Insert some lines without losing what’s there / Retain Comments / Shift what’s there to the right
A fairly simple problem
A common requirement for me is that I want to put some raw code lines into an existing script or VBA code, but I don’t want to change the line numbers referring to where they do in the existing code file.
This might occur if I want to replace some coding, but would like to keep the existing coding for future reference, possibly commented out to the right
What I might do typically for just a few lines is to manually put a comment at the start left of lines to be replaced, and then shift those now comments a few spaces to the right, then start typing the replacement lines from the left, which then pushed those comments to the left
Pictorially this is what I mean for the simple case of wanting to replace just one line

Sub Original()
Dim Msg As String
Let Msg = "Hello"
MsgBox Prompt:="Hello shit World"
End Sub
Sub ModifiedByInsertingNewCodeLine()
Dim Msg As String
Let Msg = "Hello"
Debug.Print "Hello shit World" ' MsgBox Prompt:="Hello shit World"
End Sub
That’s easy for a few lines, but for a lot of lines it’s a tedious pain in the arse

.ps1 PowerShell text like code lines
Currently have some large .ps1 PowerShell files that I am inserting a lot of lines in and want to do it in the way I am talking about
In this post I will check out the format of the files first, in case there are any unusual “invisible” characters in them, since I have seen that in some PowerShell related text files ( https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15357&viewfull=1#post15357 https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA/page3#post15357 )
Here is a File of 250 code line, that I want to put in,
Share ‘blockIPhostsRawAll250.ps1’ https://app.box.com/s/7019x59uvvxt7osvb0tojr0z4g7bfdgk ,
and here is just the first 4 lines for testing here,
Share ‘blockIPhosts4Lines.ps1’ https://app.box.com/s/37pjl9jfk9wue413xewgcjg1cdwk9dwb .
Here is a File I want to put that in from about line 200,
Share ‘Temp7BeforeIPhostsInsert.ps1’ https://app.box.com/s/fttlmwny6y4s5ub1q66kvqbrw2ppxdwz
, and here is just the first 4 lines of that for testing here,
Share ‘Temp7BeforeIPhostsInsertFirst4Lines.ps1’ https://app.box.com/s/bimxv550fpkoqndt8rz421s9vmcsorif .

Simple macro …_
'Here is a File of 250 code line, that I want to put in,
'Share ‘blockIPhostsRawAll250.ps1’ https://app.box.com/s/7019x59uvvxt7osvb0tojr0z4g7bfdgk ,
'and here is just the first 4 lines for testing here,
'Share ‘blockIPhosts4Lines.ps1’ https://app.box.com/s/37pjl9jfk9wue413xewgcjg1cdwk9dwb .
'Here is a File I want to put that in from about line 200,
'Share ‘Temp7BeforeIPhostsInsert.ps1’ https://app.box.com/s/fttlmwny6y4s5ub1q66kvqbrw2ppxdwz
', and here is just the first 4 lines of that for testing here,
'Share ‘Temp7BeforeIPhostsInsertFirst4Lines.ps1’ https://app.box.com/s/bimxv550fpkoqndt8rz421s9vmcsorif .
'
'
Sub LookInFirstBitOfTemp4andIPhosts() ' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16366&viewfull=1#post16366
' Get the text file 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 & "test4lines.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
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 'Debug.Print TotalFile
'Let TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare) ' https://i.postimg.cc/t43HCQr9/Rather-a-lot-of-Chr-0-s.jpg
'Let TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf, "", 1, 1, vbBinaryCompare)
Close #FileNum
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)
End Sub

Here is a view in the text editor of those first 4 lines, followed by what my WtchaGot_Unic_NotMuchIfYaChoppedItOff( function gives me
https://i.postimg.cc/n9kqsv63/First4-Lines-Of2ps1-Files.jpg (https://postimg.cc/n9kqsv63)

Function BlochIPhosts {param([int]$Testie)
$Check = $Testie
Write-Host "Adding telemetry domains to hosts file" # Write-Output "Adding telemetry domains to hosts file"
$hosts_file = "$env:systemroot\System32\drivers\etc\hosts"

"Function BlochIPhosts " & Chr(123) & "param" & "(" & Chr(91) & "int" & Chr(93) & "$" & "Testie" & ")" & vbCr & vbLf & " " & "$" & "Check " & "=" & " " & "$" & "Testie" & vbCr & vbLf & "Write" & "-" & "Host " & """" & "Adding telemetry domains to hosts file" & """" & " " & "#" & " Write" & "-" & "Output " & """" & "Adding telemetry domains to hosts file" & """" & vbCr & vbLf & "$" & "hosts" & "_" & "file " & "=" & " " & """" & "$" & "env" & ":" & "systemroot" & "\" & "System32" & "\" & "drivers" & "\" & "etc" & "\" & "hosts" & """"

Add-Type -AssemblyName System.Windows.Forms
[System.Windows.Forms.Application]::EnableVisualStyles() #
Remove-Variable * -ErrorAction SilentlyContinue # is needed or else a removed variable is still there when fucking about with variables. by default variables are persistant.
$ErrorActionPreference = 'SilentlyContinue'

"Add" & "-" & "Type " & "-" & "AssemblyName System" & "." & "Windows" & "." & "Forms" & vbLf & Chr(91) & "System" & "." & "Windows" & "." & "Forms" & "." & "Application" & Chr(93) & ":" & ":" & "EnableVisualStyles" & "(" & ")" & " " & "#" & vbLf & "Remove" & "-" & "Variable " & Chr(42) & " " & "-" & "ErrorAction SilentlyContinue " & "#" & " is needed or else a removed variable is still there when fucking about with variables" & "." & " by default variables are persistant" & "." & vbLf & "$" & "ErrorActionPreference " & "=" & " " & "'" & "SilentlyContinue" & "'"
Here is a screenshot of the two files in Notepad text editor
https://i.postimg.cc/n9kqsv63/First4-Lines-Of2ps1-Files.jpg (https://postimg.cc/n9kqsv63)

So, no major problems or surprises, ( or so I thought – see next post )
It looks like a different line separator is used sometimes. But we have seen this before.
I have a slight personal tendency to prefer the two character line separator, vbCr & vbLf , and also the first file was the main one in which the other will be inserted, so I will do a simple conversion to the file to be inserted to replace all vbLf with vbCr & vbLf

One small interesting note. I don’t have a last trailing line feed character or characters. That is not so usual, at least I have not experienced it yet so far in playing around with .csv and other text files

DocAElstein

02-08-2022, 09:32 PM

I hit a problem later
I hit a problem later…. The full main file actually looked like this in a text editor:
https://i.postimg.cc/4mzznGXy/Actual-Main-File.jpg (https://postimg.cc/4mzznGXy)
and it got me an 9 line array, where I was expecting one of 2102
https://i.postimg.cc/hfFLSvWN/arr-Rws-M-Bollox.jpg (https://postimg.cc/hfFLSvWN)

I don’t know how that came about since the four lines file was made and saved in the same ISE environment in which the Main file was and was saved in. But it looks like unfortunately there may be a few, 9 , vbCr & vbLfs.
So, I took a look at a shortened vision of that file, as saved in a text editor, trying to capture some of the problem areas.
This is what I looked at
https://i.postimg.cc/G8VkThB8/Actual-Main-File-Problem-Areas.jpg (https://postimg.cc/G8VkThB8)

Here is the results:

"Function BlochIPhosts " & Chr(123) & "param" & "(" & Chr(91) & "int" & Chr(93) & "$" & "Testie" & ")" & vbCr & vbLf & " " & "$" & "Check " & "=" & " " & "$" & "Testie" & vbCr & vbLf & "Write" & "-" & "Host " & """" & "Adding telemetry domains to hosts file" & """" & " " & "#" & " Write" & "-" & "Output " & """" & "Adding telemetry domains to hosts file" & """" & vbCr & vbLf & "$" & "hosts" & "_" & "file " & "=" & " " & """" & "$" & "env" & ":" & "systemroot" & "\" & "System32" & "\" & "drivers" & "\" & "etc" & "\" & "hosts" & """"

"Add" & "-" & "Type " & "-" & "AssemblyName System" & "." & "Windows" & "." & "Forms" & vbLf & Chr(91) & "System" & "." & "Windows" & "." & "Forms" & "." & "Application" & Chr(93) & ":" & ":" & "EnableVisualStyles" & "(" & ")" & " " & "#" & vbLf & "Remove" & "-" & "Variable " & Chr(42) & " " & "-" & "ErrorAction SilentlyContinue " & "#" & " is needed or else a removed variable is still there when fucking about with variables" & "." & " by default variables are persistant" & "." & vbLf & "$" & "ErrorActionPreference " & "=" & " " & "'" & "SilentlyContinue" & "'"

"Add" & "-" & "Type " & "-" & "AssemblyName System" & "." & "Windows" & "." & "Forms " & "#" & " For ps1 in PowerShell running code lines in PowerShell with Admin rights of the following form are what you need to set this off Set" & "-" & "ExecutionPolicy Unrestricted cd " & "'" & "G" & ":" & "\" & "Temp Opt" & "\" & "GitHub" & "\" & "win10script" & "-" & "master" & "\" & "My ps1 file Folder" & "'" & " " & "." & "\" & "win10debloat6Dec" & "-" & "31Dec" & "." & "ps1 " & vbLf & Chr(91) & "System" & "." & "Windows" & "." & "Forms" & "." & "Application" & Chr(93) & ":" & ":" & "EnableVisualStyles" & "(" & ")" & " " & "#" & vbLf & "Remove" & "-" & "Variable " & Chr(42) & " " & "-" & "ErrorAction SilentlyContinue " & "#" & " is needed or else a removed variable is still there when fucking about with variables" & "." & " by default variables are persistant" & "." & vbLf & "$" & "ErrorActionPreference " & "=" & " " & "'" & "SilentlyContinue" & "'" & vbLf
& "$" & "wshell " & "=" & " New" & "-" & "Object " & "-" & "ComObject Wscript" & "." & "Shell" & vbLf & "$" & "Button " & "=" & " " & Chr(91) & "System" & "." & "Windows" & "." & "MessageBoxButton" & Chr(93) & ":" & ":" & "YesNoCancel" & vbLf & "$" & "ErrorIco " & "=" & " " & Chr(91) & "System" & "." & "Windows" & "." & "MessageBoxImage" & Chr(93) & ":" & ":" & "Error" & vbLf & "If " & "(" & "!" & "(" & Chr(91) & "Security" & "." & "Principal" & "." & "WindowsPrincipal" & Chr(93) & Chr(91) & "Security" & "." & "Principal" & "." & "WindowsIdentity" & Chr(93) & ":" & ":" & "GetCurrent" & "(" & ")" & ")" & "." & "IsInRole" & "(" & Chr(91) & "Security" & "." & "Principal" & "." & "WindowsBuiltInRolpl" & vbLf & Chr(125) & ")" & vbLf & "$" & "oldcontrolpanel" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbLf & " cmd " & "/" & "c control" & vbLf & Chr(125) & ")" & vbLf & "$" & "oldsystempanel" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbLf & " cmd " & "/" & "c sysdm" & "." & "cpl" & vbLf & Chr(125
) & ")" & vbLf & "#" & " " & "$" & "oldpower" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbCr & vbLf & vbCr & vbLf & "#" & " " & Chr(125) & ")" & vbLf & "#" & " " & "$" & "restorepower" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "#" & " " & Chr(125) & ")" & vbLf & "#" & " " & "$" & "NFS" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & "#" & " " & Chr(125) & ")" & vbLf & vbLf & "#" & " " & "$" & "Virtualization" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & vbLf & "#" & " " & Chr(125) & ")" & vbLf & vbLf & "$" & "windowsupdatefix" & "." & "Add" & "_" & "Click" & "(" & Chr(123) & vbLf & " Write" & "-" & "Host " & """" & "1" & "." & " Stopping Windows Update Services" & "." & "." & "." & """" & " " & vbLf & " Stop" & "-" & "Service "
& "-" & "Name BITS " & vbLf & " " & " "

From that above output we can see 11, so that’s 10 lines rather than 9. This inconsistency by 1 is somewhat worrying.
I looked at the array produced from that shortened text file, and it is as before, 9
One possibility is that some length restriction is long some of the line feed pairs, or a line slipped in at my making of the shortened file

For the masochistic pleasure I tried the full main file in the first simple macro. To my surprise, it worked, after a few hours, the result came out.
Temp7BeforeIPhostsInsertFirst4Lines_ps1WtchaGot https://app.box.com/s/12zw9id42xrwc7qy70ul87bg0wfpb4uh
Temp7BeforeIPhostsInsertFirst4Lines_ps1WtchaGot https://app.box.com/s/771q1gzpycle7ccveu235j256n4l4xyb
It returned 8, making 9 lines.

So that discrepancy is perhaps sorted.
My initial conclusions may have based on slightly careless manipulations that brought some invisible characters in.

One possibility is that the original main coding came from GitHub: This for example talks about the line feed issue at GitHub
http://vcloud-lab.com/entries/devops/resolved-git-warning-lf-will-be-replaced-by-crlf-in-file#at_pco=smlwn-1.0&at_si=624547148f04cd41&at_ab=per-2&at_pos=0&at_tot=1

DocAElstein

02-08-2022, 09:32 PM

This is post https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA/page8#post16491
https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16491&viewfull=1#post16491
https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA/page8#post16491
https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16491&viewfull=1#post16491

So I will make a function, just for convenience even though I am not so keen on those things
It will take in
_(i) The two file names , the main one, and then the one to be inserted,
_(ii) the line at which to insert, and optional the number of lines to insert, ( if no number is given, I assume all lines want to be inserted from the second file )
_ an optional name for the output file, ( if none is given I will add something like the date to the name of the original main file, and call it that)

_(iii) Based on the results from the last post, I probably will need to keep my eye on the line feed issue. For now the way to proceed could be to first replace all vbCr & vbLf with vbLf, to get them hopefully all to the same , and then after replace all vbLf with vbCr & vbLf
_ (iv) I assume all files are in the same folder

The techniques used to bring the files into 1 dimensional array of rows are tried and trusted, used many times before. I have the main file in a master array , arrRwsM() , and the file to be merged into it is in the array, arrRws()
At the point of the code development, where these arrays were made, I checked the contents, and there was perfect agreement between the rows in the ps1 files, and the elements of the arrays.

So what is new is to combine, merge, the files as required
A simple loop will do, that tacks on the extra coding from the left in the master code array.
We don’t need to add many spaces, since usually there is already many since the commented lines are over to the right. This is a simple coding bit to do that,
______ arrRwsM(LnNbr - 1) = arrRws(LnNbr - StRw) & arrRwsM(LnNbr - 1)
For LnNbr = StRw To Rws + StRw - 1 ' This - 1 is the usual “getting end row from start row and count of rows” issue - its always (the start row) + ( Rows count - 1 )
Let arrRwsM(LnNbr - 1) = arrRws(LnNbr - StRw) & arrRwsM(LnNbr - 1) ' The - 1 here is because the one dimensional arrays start at 0, so the lines we are intersted in are 1 element back from where we might have expected them
Next LnNbr

Its extremely easy now to remake the modified text file by joining the modified array elements by a line separator,
____ TotalFile = Join(arrRwsM(), vbCr & vbLf)
( For now I will stay with the vbCr & vbLf , as my personal preference )

' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA/page8#post16491
Sub testieIt() ' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16491&viewfull=1#post16491
Call MergeScriptFiles("Temp7BeforeIPhostsInsert.ps1", "blockIPhostsRawAll250.ps1", 201, , "Temp8.ps1")
End Sub
' ByVal TxtM As String, ByVal TxtInst As String, ByVal StRw As Long, Optional ByVal Rws As Long, Optional ByVal FlNmeOut As String
Public Function MergeScriptFiles(ByVal TxtM As String, ByVal TxtInst As String, ByVal StRw As Long, Optional ByVal Rws As Long, Optional ByVal FlNmeOut As String)
Rem 1 main file
' Get the text file 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 & TxtM ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
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
Close #FileNum 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, vbCr & vbLf, vbLf, 1, -1, vbBinaryCompare)
Let TotalFile = Replace(TotalFile, vbLf, vbCr & vbLf, 1, -1, vbBinaryCompare)
' make a 1 D array of the Main text file
Dim arrRwsM() As String: Let arrRwsM() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)

Rem 2 file to insert
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & TxtInst ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
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
Close #FileNum 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, vbCr & vbLf, vbLf, 1, -1, vbBinaryCompare)
Let TotalFile = Replace(TotalFile, vbLf, vbCr & vbLf, 1, -1, vbBinaryCompare)
' make a 1 D array of the file to insert
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)

Rem 3 tack on lines from file to merge
If Rws = 0 Then Let Rws = UBound(arrRws()) + 1 ' This will cause all lines to be merged if no number of lines given
Dim LnNbr As Long
For LnNbr = StRw To Rws + StRw - 1 ' This - 1 is the usual getting end row from start row and count of rows issue - its always the start row + ( Rows count - 1 )
Let arrRwsM(LnNbr - 1) = arrRws(LnNbr - StRw) & arrRwsM(LnNbr - 1) ' The - 1 here is because the one dimensional arrays start at 0, so the lines we are intersted in are 1 element back from where we might have expected them
Next LnNbr ' LnNbr - StRw takes us from 0 to 1 less than our maximumn row number - that is exactly the 0 to (1 less than our maximumn row number)
' 3b That seems to have done it, now we just need to remake the merged text file,
' Make text file, alll we need to do is make the single long string including the line breaks that
Let TotalFile = Join(arrRwsM(), vbCr & vbLf)
Rem 4 Output file
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
If FlNmeOut = "" Then Let FlNmeOut = Left(TxtM, InStrRev(TxtM, ".") - 1) & "Merge" & Format(Now(), "dd,mmmyyyy") & ".ps1"
Let PathAndFileName2 = ThisWorkbook.Path & "\" & FlNmeOut ' ' CHANGE TO SUIT ' Will be made if not there
Open PathAndFileName2 For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Function

That above coding has got me my Temp8.ps1 which is Temp7.ps1 with the merged IP hosts block function, along with a few other things done at the end of march, including a first look at a pretty coloured GUI

' Temp7BeforeIPhostsInsert https://app.box.com/s/fttlmwny6y4s5ub1q66kvqbrw2ppxdwz
https://i.postimg.cc/T2K3rjbC/hosts-Before-2022-04.jpg

' blockIPhostsRawAll250 https://app.box.com/s/7019x59uvvxt7osvb0tojr0z4g7bfdgk

https://i.postimg.cc/pV3Xk9Yx/hosts-After-2022-04.jpg
' Temp8.ps1 https://app.box.com/s/9b9li86s7dyysr7exdle30pckgp7vscz

DocAElstein

02-08-2022, 09:32 PM

In support of this post https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page53#post12804
A similar requirement to the last post, but for purposes of comparing a change in script by having the two versions side by side
I will do the whole thing again, just to see if I still experience similar effects on a different day.

I am interested in what seems to be a change by Chris Titus to his recent “WPF” windows utility
This change was somehow in between others, ( (ii) inbetween (i) and (iii) ), so may have slipped past most people.
I am taking my data from this red and green stuff , middle in Commit thing,
Mistery Red and Green stuff https://github.com/ChrisTitusTech/winutil/commit/a4019d74ec3fca44208eb3b621d6f8ac9bee5a64
or maybe not… This is what I have
The previous XML from god knows where and when, ( the red stuff from that last link )
Share ‘May10-17XML.txt’ https://app.box.com/s/ykynprd9a3ra4w7kcif4h5ziubwktw2t
The “new” green stuff from that last link
Share ‘May17XML.txt’ https://app.box.com/s/gsqjpfmmqwpadmu8wchjrlfrqxwrrg6e

_ (iii) This is now from the next change the next change called up XML thing

The big mystery seems to be for now where and what that red stuff comes from or is.
It seems that the full script from 10 May, the full script from just before the last change (ii) on 17May, and the stand alone XLM in change (iii) all have the same XML stuff

I think I will leave it for now… It’s all a total mess. It looks like he changed something he was never using to update it to what he was using.

….. later

Share ‘ChrisWPFTuesday10May2022.ps1’ https://app.box.com/s/end0t4spyl119iiixw9va922hdft4icx

Mistery Red and Green stuff https://github.com/ChrisTitusTech/winutil/commit/a4019d74ec3fca44208eb3b621d6f8ac9bee5a64
Share ‘ChrisWPF17May2022(ii).ps1’ https://app.box.com/s/yrzoikeg9coggyt99ofin18f2cxkf849
Share ‘May10-17XML.txt’ https://app.box.com/s/ykynprd9a3ra4w7kcif4h5ziubwktw2t
Share ‘May17XML.txt’ https://app.box.com/s/gsqjpfmmqwpadmu8wchjrlfrqxwrrg6e

The new thng thing (iii) , https://github.com/ChrisTitusTech/winutil/commit/7d4727b51be22ecfbff953357789e4d5d2923b63
https://i.postimg.cc/fR8Hhcv1/Git-Hub17-May-Update-XML.jpg
https://i.postimg.cc/90y83sxB/The-new-thing-iii.jpg
https://i.postimg.cc/vHd27HB2/The-new-thng-thing-iii.jpg
https://raw.githubusercontent.com/ChrisTitusTech/winutil/main/MainWindow.xaml
Share ‘MainWindow_xami - StandAloneXML17May.txt’ https://app.box.com/s/lrf37fuhegad3jfgjltzlmckmw33lpj2
Share ‘MainWindow.xaml’ https://app.box.com/s/3b6v4zmgb6njamh6khyqe44zpk7cmaak

Share ‘ChrisWPF17May2022.ps1’ https://app.box.com/s/lrzeyx55hjksedzrr649snrxfmfyvtkm
Share ‘ChrisWPF17May2022(iii).ps1’ https://app.box.com/s/7u4lxbwrgubxgf37tduzx0e22s49alvf

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use
:mad:

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Link to this post #73 #Post19687
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page8#Post19687
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page8#Post19687
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19687&viewfull=1#post19687
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19687&viewfull=1#post19687
https://bit.ly/3Xy3ZEF https://bit.ly/3I4YEz7

February 2023...... Frankenstein YouTube Zimmer taking shape... https://postimg.cc/gallery/QFt2XdX

Temporary Bench https://i.postimg.cc/PJtH2LV4/CIMG5716.jpg ... collecting all the computers and such together
Scaffolding Bars ... Picked out and cleaned the newest / shiniest of all my Scaffolding bars ... to hang things from .... and swing around like an ape to keep fit...

Burning open fire .. in the corner of the Dungeon room … maybe I will leave it like that, messy and raw, sit there Naked with my bask to the fire and make a real gruesome look

https://i.postimg.cc/4xJsDSmv/CIMG5710.jpg
4811https://i.postimg.cc/pp1w8kQy/CIMG5710.jpg (https://postimg.cc/pp1w8kQy)https://i.postimg.cc/4xJsDSmv/CIMG5710.jpg (https://postimg.cc/pp1w8kQy)

https://i.postimg.cc/KYkVwPrr/CIMG5711.jpg
4812https://i.postimg.cc/XZWQyyPp/CIMG5711.jpg (https://postimg.cc/XZWQyyPp)

https://i.postimg.cc/yYsMxSss/CIMG5712.jpg
4813https://i.postimg.cc/K4pqsj1H/CIMG5712.jpg (https://postimg.cc/K4pqsj1H)

https://i.postimg.cc/P5q0zsC7/CIMG5713.jpg
4814https://i.postimg.cc/RNjP4YQ1/CIMG5713.jpg (https://postimg.cc/RNjP4YQ1)

4815 https://i.postimg.cc/YCyZdngC/CIMG5715.jpg
https://i.postimg.cc/YvYd9xb5/CIMG5715.jpg
(https://postimg.cc/YvYd9xb5)https://i.postimg.cc/PJtH2LV4/CIMG5716.jpg (https://postimg.cc/R6b200B6)

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use...... This is post #75 #post19689
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19689&viewfull=1#post19689
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19689&viewfull=1#post19689

white Snow stuff is a very special thing that comes down from the sky here and makes everything very Pretty. It also makes the ground nice and soft to go jogging on. I like it a lot.
For one year I did find a nice old disused railway line and in winter when it snows it is very Beautiful and I look forward every evening to my Jog. It is like my own private jogging train line.
https://i.postimg.cc/cHMDFZrr/Soft-Snow-to-Jog-On.jpg
https://i.postimg.cc/7YBRvxXz/Auf-meine-Jog-Weg-Taucht-das-Schnee-zu-letzter.jpg
https://i.postimg.cc/pTtGQyVw/Beautiful-Jogging.jpg
https://i.postimg.cc/JhXYBj83/Old-Disused-Railway.jpg
https://i.postimg.cc/T3FHwCzY/Pretty-Snow.jpg
_.________________

https://postimg.cc/gallery/vBm1X8g

https://i.postimg.cc/cHMDFZrr/Soft-Snow-to-Jog-On.jpg (https://postimages.org/)

https://i.postimg.cc/JhXYBj83/Old-Disused-Railway.jpg (https://postimages.org/)

https://i.postimg.cc/7YBRvxXz/Auf-meine-Jog-Weg-Taucht-das-Schnee-zu-letzter.jpg (https://postimg.cc/rKrjx2By)

https://i.postimg.cc/T3FHwCzY/Pretty-Snow.jpg (https://postimages.org/)

https://i.postimg.cc/pTtGQyVw/Beautiful-Jogging.jpg (https://postimages.org/)

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

Eine Sonntag arbenteuer

07.11.2021, 18:38

Also, wir laufen, und da wo ich sonnst im dunkel jog, kann man im Herbst tags grade noch was da drüben sehen … evtl. eine alte abstell gleise???

https://i.postimg.cc/fWBK2nYY/1-Was-Rechts-Evtl.jpg

Aber wir Lauf zu erste weiter..

Es ist ja interessant was man auf dem weg für abfall seiht-

https://i.postimg.cc/ncNWHj0H/2-Interesant-Abfall.jpg

Eine Voll milch , Bergator..

https://i.postimg.cc/J7DcRTgk/3-Ein-Berghator-Voll-Milch.jpg

Also was passiertet wenn der richtigen Weg geht rechts, und eine alte kleine weg geht links… Die meiste Leute Endscheidung die normaller weg

https://i.postimg.cc/KYpB2LDf/4-Weg-geht-rechts.jpg

Ich und Pooh , geh aber links entlang

https://i.postimg.cc/wMwdfqp1/5-wir-gehen-aber-links.jpg

Bald kommt das weg zu ende…

https://i.postimg.cc/wxfX55dV/6-Weg-endet.jpg

Aber da drüben ist was – eine Groß Kompost berg… ( in der Feld hinter war jemand für eine paar tagen gejagt bei eine Wolf in dunkel )

https://i.postimg.cc/kg8WdkR1/7-eiune-gross-posty-berg-da-druben.jpg

Links unter im Bild seiht man aber was…

https://i.postimg.cc/vHxVWphY/8-da-links-ist-was.jpg

Ein Loch - Da hat jemand im Dunkel auch hingefallen als er weg ran von die Wolf

https://i.postimg.cc/W4NzfKGJ/9-eine-gross-loch-aber-was-ist-da-links-unter.jpg

Beim aufstehen damals habe ich eine gleise end entdeckt. ( das sieht man gerade noch in das letzte Bild, links unten )

Ws ist die Ende eine alte gleise, und jemand sitz da…

https://i.postimg.cc/7Zmm55NG/11-ein-gleise-end.jpg

Ach so, Tigger passt auf das keine Zug zu weit fahrt, Die arme sitz da in seiner orange regen Jacke , Geschütz von wetter

https://i.postimg.cc/cJLkhRJB/12-da-wacht-jemand-auf.jpg

In die andere Richtung ist interessant

https://i.postimg.cc/cHK9ydwK/13-inder-ander-richtung.jpg

Sieht wie eine alte Bahnhof

https://i.postimg.cc/g2kKbYPY/14-eine-klein-alte-bahnhof.jpg

Aber da ist was auf dem gleise

https://i.postimg.cc/j5VN2TBn/19-was-ist-das.jpg

Eine naughty Pumkin sitz auf dem Gleise – wahrscheinlich weil er war langweiliges so lange auf eine Zug zu warten.

https://i.postimg.cc/pTDjn7tG/21-Ein-naught-pumpkin.jpg

Aber , Bahnhof Station meister sagt ihm er soll zurück auf Bahnsteig

Und beide warte auf Zug ordentlich

https://i.postimg.cc/05nMR75w/22-ordentlisch-warten-auf-zug.jpg

Mir ist aber aufgefallen das keine Zug kommt…

https://i.postimg.cc/VkdbF58b/23-kommt-aber-keine-Muss-schauern.jpg

Ich schau also weiter

Auch so …

https://i.postimg.cc/rwBzCJjv/24-Auch-so-alles-zug-nach-plauern-nur.jpg

alle Zug geht rechts nach Plauern, weil weicher geht rechts/ geraderaus. Also, ruf ich der Station Meister Pooh

Er macht sich auf die arbeite

https://i.postimg.cc/d3NV7mDN/25-Pooh-sets-weichern.jpg

Und jetzt wurde alle Zug umgeleitet zu unserer Bahnhof

https://i.postimg.cc/SxMxs94V/26-zug-geht-jetzt-zu-Pooh-bahnhof.jpg

( Aber echt – es ist Wahnsinn – das weicher ist voll ge- öled und gefettet – es funktioniert – da kann jede Kind oder verruchte die Zug um leiten – gibt’s keine schalte, Kamera, schloss, oder sonnst es zu verhindern.)

Ist aber echt dumm oder..

Keine Angst, Pooh hast wieder zurück

https://i.postimg.cc/MHHW8Mt7/27-Weicher-weider-zuruck.jpg

Ich schau weiter, da ist eine blick das mir von Hitchin erinnert wo ich bei eine Brücke unter gegangen war von meine Jogg weg

https://i.postimg.cc/jdzsYb4k/28-Hitchin-blick.jpg

Aber ich geh weiter

https://i.postimg.cc/Z5thwMkF/29-es-geht-weiter.jpg

Und weiter

https://i.postimg.cc/zDHzpWbN/31-Und-weiter.jpg

Wer arbeitet dort vorher..

https://i.postimg.cc/qBKr2TSM/32-wer-arbeitet-dort.jpg

Auch so, immer viele zu tun fürs Station meister Pooh, er muss Ester weg sägen von seine gleise

https://i.postimg.cc/tJQLBswR/33-ach-so-Pooh-s-ged-ester-weg-von-seine-gleise.jpg

Er hat ja, sehr viele zu tun, aber heute habe ihm viel Gehilfen und neben bei mehrere Brenn Holz lager platz gemacht

https://i.postimg.cc/MTRLfWTC/34-Pooh-hat-veil-zu-tun-Ich-schau-allein-weiter.jpg

Mann konnte denken die gleis hört auf

https://i.postimg.cc/Y00mySWV/35-End-Ich-denk-nicht.jpg

Aber es geht noch weiter,

https://i.postimg.cc/LsVY9Pkw/36-weiter.jpg

Dann geht rechts zu interessant schön Holz teile

https://i.postimg.cc/BnHPzkjq/37-rechts-zu-gross-Bau-Holz-lager-platz.jpg

Gerade und links, geht so wie eine blick zu Dachau….

https://i.postimg.cc/26wK70QG/38-links-und-gerade-aus-zu-Daschau.jpg

Aber bei Tages licht geh ich nicht weiter, ich gen links

https://i.postimg.cc/WbD5dNHX/39-bei-tagres-licjt-geh-ich-nicht-weiter.jpg

Ich mach eine letzter Bild von meine neue schön gefundener bretter und Balkon Holz Vorrat…

https://i.postimg.cc/MTPYGN0C/41-letzter-Photo-von-meine-neue-gelargeter-holz-bretter.jpg

Ich denk, da Links oben konnte was ….

https://i.postimg.cc/hhFTzBX5/42-links-uben-ist-was-denk-ich.jpg

Beispielsweise links eine Zug

https://i.postimg.cc/JzNcXGcc/43-beispiels-weise-links-zug.jpg

Mir ist aber rechts was mehr interessant, … konnte eine alte weg…

https://i.postimg.cc/qvsS7BNW/44-rects-konnte-eine-weg.jpg

Hatte recht, noch neben die Bahn strecke, eine alte weg

https://i.postimg.cc/fWd6Pvww/45-alte-gleise-weg-evt.jpg

Der Gleise ist weg, aber trotzdem eine schön Boingy Boingy jogg weg..

https://i.postimg.cc/MXk3WgqW/46-ja-gleise-weg-aber-schon-boingy-jog-weg.jpg

irgendwann ist aber die schnell wachsender weise Rind baumle zu dick gewachsen

https://i.postimg.cc/y8nqPY7c/47-die-schnell-w-chsender-weise-rind-baumla-speer-weg-weiter.jpg

Aber echts daneben ist eine schön weise

https://i.postimg.cc/0yKmGrYH/48-Aber-rechst-ist-schon-weise.jpg

Ich denke sogar ist es rasen gemährt

https://i.postimg.cc/NGRzDf4F/49-sogar-gem-ht-weise.jpg

Weise du wo ich jetzt da bin?

https://i.postimg.cc/6Q1Dkj2Q/51-weise-du-wo.jpg

Noch nicht weise? – jetzt aber

https://i.postimg.cc/8P9fCD2d/52-noch-nicht-kennt-sich.jpg

Jetzt sollst Du wissen. Die tour ist fast fertig. Rechts unter ist Vissmann.

https://i.postimg.cc/RFgNxz1H/53-jetzt-sollst-wissen.jpg

Links über der Bahn Übergang geht’s zu studentenberg – ich komm also raus von meine jogg weg an die andere seit von vor das normaller weg geht zu Feilitzch.

Das wars

Gesichte Ende…

:)

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

02-08-2022, 09:32 PM

Another post for later use

DocAElstein

06-01-2022, 01:25 AM

Page 9 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page9

Popular videos So geht YouTube
https://www.youtube.com/@SogehtYouTube/videos?view=0&sort=p&shelf_id=0
https://www.youtube.com/playlist?list=UULPwInqvNXb-GN0JHdtoul_9A

Unlisted
So geht YouTube
https://www.youtube.com/@SogehtYouTube
1 / 667 Play all

https://www.youtube.com/watch?v=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A
https://www.youtube.com/watch?v=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A&index=1
https://www.youtube.com/watch?v=h15o6YLzfqc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=76
https://www.youtube.com/watch?v=cYJxctyMO2s&list=UULPwInqvNXb-GN0JHdtoul_9A&index=151
https://www.youtube.com/watch?v=dcQNQP9i_WE&list=UULPwInqvNXb-GN0JHdtoul_9A&index=226
https://www.youtube.com/watch?v=FDg34qCE8-Y&list=UULPwInqvNXb-GN0JHdtoul_9A&index=301
https://www.youtube.com/watch?v=t_Xuqu6Rw2Q&list=UULPwInqvNXb-GN0JHdtoul_9A&index=376
https://www.youtube.com/watch?v=5DkjHTTqIPc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=451
https://www.youtube.com/watch?v=1tT7m5qAR4o&list=UULPwInqvNXb-GN0JHdtoul_9A&index=526
https://www.youtube.com/watch?v=g9kOyaXsJlk&list=UULPwInqvNXb-GN0JHdtoul_9A&index=601

DocAElstein

06-01-2022, 01:25 AM

Some extra stuff for this post
https://eileenslounge.com/viewtopic.php?f=27&t=38243

later

DocAElstein

06-13-2022, 02:09 PM

In support of this main forum Thread
https://excelfox.com/forum/showthread.php/2797-find-last-alphanumeric-row-of-txt-file-and-fill-into-excel-cell
_1) create new number and place in cell B1 according to last serial number in csv file,

Before
ExcelFile:
_____ Workbook: SerialNumbers.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1Serial# :TTR0000001

2TTR0000002

3TTR0000003

4
Worksheet: Sheet1

Text File:

TTR0000001
TTR0000002
TTR0000003

Run macro:

Sub NewSN()
' Rem 1 Get the text file 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 & "serial_number.csv" '
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 determine a new number
'2a Current number
If Right(TotalFile, 2) = vbCr & vbLf Then Let TotalFile = Left(TotalFile, Len(TotalFile) - 2) ' Take off last line feed
Dim PosLstLineFeed As Long: Let PosLstLineFeed = InStrRev(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim CrntNmbr As String: Let CrntNmbr = Mid(TotalFile, PosLstLineFeed + 2)
Let CrntNmbr = Replace(CrntNmbr, "TTR", "", 1, -1, vbBinaryCompare)
'2b creat new number
Let CrntNmbr = CrntNmbr + 1
Let CrntNmbr = Format(CrntNmbr, "0000000")
Let CrntNmbr = "TTR" & CrntNmbr

Rem 3 Put new number in Excel file
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim LrB As Long: Let LrB = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
Let Ws1.Range("B" & LrB + 1 & "").Value = CrntNmbr
End Sub

After:

_____ Workbook: SerialNumbers.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1Serial# :TTR0000001

2TTR0000002

3TTR0000003

4TTR0000004

5
Worksheet: Sheet1

DocAElstein

06-13-2022, 02:09 PM

In support of this main forum Thread
https://excelfox.com/forum/showthread.php/2797-find-last-alphanumeric-row-of-txt-file-and-fill-into-excel-cell
_1) create new number and place in cell B1 according to last serial number in csv file,

Before
ExcelFile:
_____ Workbook: SerialNumbers.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1Serial# :TTR0000001

2TTR0000002

3TTR0000003

4
Worksheet: Sheet1

Text File:

TTR0000001
TTR0000002
TTR0000003

Run macro:

Sub NewSN()
' Rem 1 Get the text file 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 & "serial_number.csv" '
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 determine a new number
'2a Current number
If Right(TotalFile, 2) = vbCr & vbLf Then Let TotalFile = Left(TotalFile, Len(TotalFile) - 2) ' Take off last line feed
Dim PosLstLineFeed As Long: Let PosLstLineFeed = InStrRev(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim CrntNmbr As String: Let CrntNmbr = Mid(TotalFile, PosLstLineFeed + 2)
Let CrntNmbr = Replace(CrntNmbr, "TTR", "", 1, -1, vbBinaryCompare)
'2b creat new number
Let CrntNmbr = CrntNmbr + 1
Let CrntNmbr = Format(CrntNmbr, "0000000")
Let CrntNmbr = "TTR" & CrntNmbr

Rem 3 Put new number in Excel file
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim LrB As Long: Let LrB = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
Let Ws1.Range("B" & LrB + 1 & "").Value = CrntNmbr
End Sub

After:

_____ Workbook: SerialNumbers.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1Serial# :TTR0000001

2TTR0000002

3TTR0000003

4TTR0000004

5
Worksheet: Sheet1

DocAElstein

06-13-2022, 02:43 PM

In support of this main forum Thread
https://excelfox.com/forum/showthread.php/2797-find-last-alphanumeric-row-of-txt-file-and-fill-into-excel-cell
_2) save new serial number to csv file below last numbers.

Before :
text File

TTR0000001
TTR0000002
TTR0000003

Excel File
_____ Workbook: SerialNumbers.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1Serial# :TTR0000001

2TTR0000002

3TTR0000003

4TTR0000004

5
Worksheet: Sheet1

Run this macro

' https://excelfox.com/forum/showthread.php/2797-find-last-alphanumeric-row-of-txt-file-and-fill-into-excel-cell
Sub SaveLatestSNinTextFile()
Rem 1 Get the text file 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 & "serial_number.csv" '
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 latest serial nimber from Excel file
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim LrB As Long: Let LrB = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
Dim CrntNmbr As String: Let CrntNmbr = Ws1.Range("B" & LrB & "").Value

Rem 3 add latest serial number to text file
' 3a add a new line and the latest serial number to the string of the entire file
If Right(TotalFile, 2) = vbCr & vbLf Then Let TotalFile = Left(TotalFile, Len(TotalFile) - 2)
Let TotalFile = TotalFile & vbCr & vbLf & CrntNmbr '
' 3b replace the text file with the new string
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Sub

After:

TTR0000001
TTR0000002
TTR0000003
TTR0000004

DocAElstein

06-13-2022, 02:43 PM

In support of this main forum Thread
https://excelfox.com/forum/showthread.php/2797-find-last-alphanumeric-row-of-txt-file-and-fill-into-excel-cell
_2) save new serial number to csv file below last numbers.

Before :
text File

TTR0000001
TTR0000002
TTR0000003

Excel File
_____ Workbook: SerialNumbers.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1Serial# :TTR0000001

2TTR0000002

3TTR0000003

4TTR0000004

5
Worksheet: Sheet1

Run this macro

' https://excelfox.com/forum/showthread.php/2797-find-last-alphanumeric-row-of-txt-file-and-fill-into-excel-cell
Sub SaveLatestSNinTextFile()
Rem 1 Get the text file 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 & "serial_number.csv" '
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 latest serial nimber from Excel file
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim LrB As Long: Let LrB = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
Dim CrntNmbr As String: Let CrntNmbr = Ws1.Range("B" & LrB & "").Value

Rem 3 add latest serial number to text file
' 3a add a new line and the latest serial number to the string of the entire file
If Right(TotalFile, 2) = vbCr & vbLf Then Let TotalFile = Left(TotalFile, Len(TotalFile) - 2)
Let TotalFile = TotalFile & vbCr & vbLf & CrntNmbr '
' 3b replace the text file with the new string
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Sub

After:

TTR0000001
TTR0000002
TTR0000003
TTR0000004

DocAElstein

09-14-2022, 12:07 PM

In support of this main forum Thread post:
https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found?p=16695&viewfull=1#post16695

content in one line input reduced sample.txt https://app.box.com/s/grrxh1rl372pzp2exn6em00ovhj4qhih
content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos

https://i.postimg.cc/yYdStNqH/Before-and-After-Reduce-text-Lines-reduced-sample.jpg (https://postimg.cc/V5x6bmLG)

What’s those two text files got in them?:
Using the Function , Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String, Optional ByVal FlNme As String) '
, from here: https://excelfox.com/forum/showthread.php/2302-quot-What%e2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=15524&viewfull=1#post15524
https://pastebin.com/eutzzxHv

, and using this Calling macro

' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16696&viewfull=1#post16696
Sub SantaComing()
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

Here is the results, for example from the immediate window :

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems " & vbCr & vbLf & "in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short " & vbCr & vbLf & "stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & vbCr & vbLf & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story " & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that " & vbCr & vbLf & "the story has somehow wormed"

Here are the corresponding results if I do the same to look at the after file ( content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos )

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed"

So, what do we conclude?:
_ 1) there are no tab characters
_ 2) It seems that the line separator is the commonly used 2 character pair of a carriage return and a line feed, ( In VBA coding, vbCr & vbLf )
_ 3) It seems like the character string we wish to remove, ( the extra new line forming characters ) are three character:
A space and a carriage return and a line feed. ( In VBA coding _ " " & vbCr & vbLf _ )
( _ 4) I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I will do that!)

This initial macro seems to do the required:

Sub ReplaceInTextFileThreeCharacters__Space_vbCr_vbLf_ _WithA__Space__() ' https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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 remove " " & vbCr & vbLf
' Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, "", 1, -1, vbBinaryCompare)
Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, " ", 1, -1, vbBinaryCompare) ' I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I do that!
Rem 3 Make new file
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "new text file.txt"
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Sub

Here is the corresponding output from my function for the new text file made

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed" & vbCr & vbLf
That looks very similar to the output requested. Here is the new text file made:
new text file.txt https://app.box.com/s/w2zydwa20lr3jyxuk8z7ddjgpl0xrcvn

SantaClawsIsComing.xls https://app.box.com/s/7ken6nf050xd4xqwhxu3av1yebdb74dr

DocAElstein

09-14-2022, 12:07 PM

In support of this main forum Thread post:
https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found?p=16695&viewfull=1#post16695

content in one line input reduced sample.txt https://app.box.com/s/grrxh1rl372pzp2exn6em00ovhj4qhih
content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos

https://i.postimg.cc/yYdStNqH/Before-and-After-Reduce-text-Lines-reduced-sample.jpg (https://postimg.cc/V5x6bmLG)

What’s those two text files got in them?:
Using the Function , Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String, Optional ByVal FlNme As String) '
, from here: https://excelfox.com/forum/showthread.php/2302-quot-What%e2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=15524&viewfull=1#post15524
https://pastebin.com/eutzzxHv

, and using this Calling macro

' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16696&viewfull=1#post16696
Sub SantaComing()
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

Here is the results, for example from the immediate window :

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems " & vbCr & vbLf & "in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short " & vbCr & vbLf & "stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & vbCr & vbLf & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story " & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that " & vbCr & vbLf & "the story has somehow wormed"

Here are the corresponding results if I do the same to look at the after file ( content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos )

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed"

So, what do we conclude?:
_ 1) there are no tab characters
_ 2) It seems that the line separator is the commonly used 2 character pair of a carriage return and a line feed, ( In VBA coding, vbCr & vbLf )
_ 3) It seems like the character string we wish to remove, ( the extra new line forming characters ) are three character:
A space and a carriage return and a line feed. ( In VBA coding _ " " & vbCr & vbLf _ )
( _ 4) I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I will do that!)

This initial macro seems to do the required:

Sub ReplaceInTextFileThreeCharacters__Space_vbCr_vbLf_ _WithA__Space__() ' https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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 remove " " & vbCr & vbLf
' Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, "", 1, -1, vbBinaryCompare)
Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, " ", 1, -1, vbBinaryCompare) ' I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I do that!
Rem 3 Make new file
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "new text file.txt"
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Sub

Here is the corresponding output from my function for the new text file made

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed" & vbCr & vbLf
That looks very similar to the output requested. Here is the new text file made:
new text file.txt https://app.box.com/s/w2zydwa20lr3jyxuk8z7ddjgpl0xrcvn

SantaClawsIsComing.xls https://app.box.com/s/7ken6nf050xd4xqwhxu3av1yebdb74dr

DocAElstein

09-14-2022, 12:07 PM

In support of this main forum Thread post:
https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found?p=16695&viewfull=1#post16695

content in one line input reduced sample.txt https://app.box.com/s/grrxh1rl372pzp2exn6em00ovhj4qhih
content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos

https://i.postimg.cc/yYdStNqH/Before-and-After-Reduce-text-Lines-reduced-sample.jpg (https://postimg.cc/V5x6bmLG)

What’s those two text files got in them?:
Using the Function , Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String, Optional ByVal FlNme As String) '
, from here: https://excelfox.com/forum/showthread.php/2302-quot-What%e2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=15524&viewfull=1#post15524
https://pastebin.com/eutzzxHv

, and using this Calling macro

' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16696&viewfull=1#post16696
Sub SantaComing()
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

Here is the results, for example from the immediate window :

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems " & vbCr & vbLf & "in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short " & vbCr & vbLf & "stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & vbCr & vbLf & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story " & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that " & vbCr & vbLf & "the story has somehow wormed"

Here are the corresponding results if I do the same to look at the after file ( content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos )

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed"

So, what do we conclude?:
_ 1) there are no tab characters
_ 2) It seems that the line separator is the commonly used 2 character pair of a carriage return and a line feed, ( In VBA coding, vbCr & vbLf )
_ 3) It seems like the character string we wish to remove, ( the extra new line forming characters ) are three character:
A space and a carriage return and a line feed. ( In VBA coding _ " " & vbCr & vbLf _ )
( _ 4) I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I will do that!)

This initial macro seems to do the required:

Sub ReplaceInTextFileThreeCharacters__Space_vbCr_vbLf_ _WithA__Space__() ' https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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 remove " " & vbCr & vbLf
' Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, "", 1, -1, vbBinaryCompare)
Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, " ", 1, -1, vbBinaryCompare) ' I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I do that!
Rem 3 Make new file
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "new text file.txt"
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Sub

Here is the corresponding output from my function for the new text file made

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed" & vbCr & vbLf
That looks very similar to the output requested. Here is the new text file made:
new text file.txt https://app.box.com/s/w2zydwa20lr3jyxuk8z7ddjgpl0xrcvn

SantaClawsIsComing.xls https://app.box.com/s/7ken6nf050xd4xqwhxu3av1yebdb74dr

DocAElstein

09-14-2022, 12:07 PM

In support of this main forum Thread post:
https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found?p=16695&viewfull=1#post16695

content in one line input reduced sample.txt https://app.box.com/s/grrxh1rl372pzp2exn6em00ovhj4qhih
content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos

https://i.postimg.cc/yYdStNqH/Before-and-After-Reduce-text-Lines-reduced-sample.jpg (https://postimg.cc/V5x6bmLG)

What’s those two text files got in them?:
Using the Function , Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String, Optional ByVal FlNme As String) '
, from here: https://excelfox.com/forum/showthread.php/2302-quot-What%e2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=15524&viewfull=1#post15524
https://pastebin.com/eutzzxHv

, and using this Calling macro

' https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=16696&viewfull=1#post16696
Sub SantaComing()
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

Here is the results, for example from the immediate window :

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems " & vbCr & vbLf & "in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short " & vbCr & vbLf & "stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & vbCr & vbLf & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story " & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that " & vbCr & vbLf & "the story has somehow wormed"

Here are the corresponding results if I do the same to look at the after file ( content in one line output reduced sample.txt https://app.box.com/s/mpyvgf4kj9q04szjtj0255cns24lbxos )

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed"

So, what do we conclude?:
_ 1) there are no tab characters
_ 2) It seems that the line separator is the commonly used 2 character pair of a carriage return and a line feed, ( In VBA coding, vbCr & vbLf )
_ 3) It seems like the character string we wish to remove, ( the extra new line forming characters ) are three character:
A space and a carriage return and a line feed. ( In VBA coding _ " " & vbCr & vbLf _ )
( _ 4) I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I will do that!)

This initial macro seems to do the required:

Sub ReplaceInTextFileThreeCharacters__Space_vbCr_vbLf_ _WithA__Space__() ' https://excelfox.com/forum/showthread.php/2817-Make-all-text-file-content-in-one-line-if-a-space-found
' Rem 1 Get the text file 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 & "content in one line input reduced sample.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 remove " " & vbCr & vbLf
' Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, "", 1, -1, vbBinaryCompare)
Let TotalFile = Replace(TotalFile, " " & vbCr & vbLf, " ", 1, -1, vbBinaryCompare) ' I expect the OP, ( susan santa 12345 et al. ) , probably would not want to remove all that, but rather replace it with a single space , so I do that!
Rem 3 Make new file
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "new text file.txt"
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Output As #FileNum2
Print #FileNum2, TotalFile ' write out entire text file
Close #FileNum2
End Sub

Here is the corresponding output from my function for the new text file made

Chr(239) & Chr(187) & Chr(191) & "1111" & "." & " Last year" & "," & " I put together this list of the most iconic poems in the English language" & ";" & " it" & Chr(226) & ChrW(8364) & ChrW(8482) & "s high time to do the same for short stories" & "." & " But before we go any further" & "," & " you may be asking" & ":" & " What does " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " mean in this context" & "?" & " Can a short story really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "really be iconic in the way of a poem" & "," & " or a painting" & "," & " or Elvis" & "?" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Well" & "," & " who knows" & "," & " but for our purposes" & "," & " " & Chr(226) & ChrW(8364) & ChrW(339) & "iconic" & Chr(226) & ChrW(8364) & Chr(157) & " means that the story has somehow wormed" & vbCr & vbLf
That looks very similar to the output requested. Here is the new text file made:
new text file.txt https://app.box.com/s/w2zydwa20lr3jyxuk8z7ddjgpl0xrcvn

SantaClawsIsComing.xls https://app.box.com/s/7ken6nf050xd4xqwhxu3av1yebdb74dr

DocAElstein

09-29-2022, 01:33 PM

This is post https://www.excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping/page10
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping?p=19700&viewfull=1#post19700
https://www.excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping/page10
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping?p=19700&viewfull=1#post19700

In support of this main Forum thread
https://eileenslounge.com/viewtopic.php?p=303644#p303644
In particular latest post : https://eileenslounge.com/viewtopic.php?p=303704#p303704

First quick working attempt

DocAElstein

09-29-2022, 01:33 PM

In support of this main Forum thread
https://eileenslounge.com/viewtopic.php?p=303644#p303644

First quick working attempt
Some brief notes of what I did, problems etc.
_ In the long play list I looked at it seems you only get a text file of all the stuff I want for a bit more than 75 videos at a time. This makes sense and ties up with the experience when you view manually in real time: The scroll box only goes up to on average a bit over the first 75.
https://i.postimg.cc/phX1XqkM/Only-get-79-vids-in-one-go.jpg (https://postimg.cc/phX1XqkM)

Scrapping that, or rather to say, playing around with the text file from the page source text from this

https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A ' -- main play list link
,give links of this form
https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A&index=1
https://www.youtube.com/watch?v=YsnmNoq6OTg&list=UULFwInqvNXb-GN0JHdtoul_9A&index=2
https://www.youtube.com/watch?v=KIx_8comGEc&list=UULFwInqvNXb-GN0JHdtoul_9A&index=3
…….. up to about &index=79
If you want the next chunk of videos, and a new text file of it all, you have to click on a video towards the bottom. ( https://i.postimg.cc/65L3ydNF/Click-towards-bottom-to-get-next-lot.jpg ) I thought I would keep stuff in some organised order, so tried getting all the text in a text file from these 9 links, the ones ending with &index=1, &index=76, &index=151, &index=226 …. 301, 376,451,526,601
That sort of worked…. Eventually…
_ I end up with 9 big text files to play with So that is sort of Part 1. I got now all the info I need, somewhere I expect, in those files… https://i.postimg.cc/R06JWCxf/9-Big-Server-Chrome-hybrid-text-files.jpg
https://i.postimg.cc/R3mZ8BFV/9-Big-Server-Chrome-hybrid-text-files.jpg (https://postimg.cc/R3mZ8BFV)

WieGehtsYouTubeServerChrome1.txt https://app.box.com/s/0r4fsgn31gjtzoep22e31378m719znh7
WieGehtsYouTubeServerChrome76.txt https://app.box.com/s/c2y7978m1o4qqzeia15vaz2ry6jygndo
WieGehtsYouTubeServerChrome151.txt https://app.box.com/s/aj1a0gdg45lhwu24nsykihz3ln3opj2z
WieGehtsYouTubeServerChrome226.txt https://app.box.com/s/or5vbv6abv2zb8mtnsz5z54u895fgn7e
WieGehtsYouTubeServerChrome301.txt https://app.box.com/s/j0cry0vh93w17g5m2mjtzvg0dcvb1437
WieGehtsYouTubeServerChrome376.txt https://app.box.com/s/d62s25tmv1mdfvyhxhxvcnvxf8bkde3q
WieGehtsYouTubeServerChrome451.txt https://app.box.com/s/uxt1secic6beh8ejh22g79pzpj61qox6
WieGehtsYouTubeServerChrome526.txt https://app.box.com/s/h5vakr7abi0r3edzhjdkrdcecanfxoh2
WieGehtsYouTubeServerChrome601.txt https://app.box.com/s/eftpuaxfnl8nrsvt6xbo0vn3n4klv2wb

_ a small snag: Previously using the main link, https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A , gets the first 79 links and with the index number, which is not essential but useful to have. But use a link with the extra &index=123 and I can’t find or get the index number from those 9 text files. Could be hidden there somewhere. I can’t see it initially. Maybe later.
No matter, not so important
_ ( I am actually using initially a hybrid Yasser/ SpeakEasy suggestion code to get those. So
Object "MSXML2.ServerXMLHTTP"
and the
.setRequestHeader "User-Agent", "Chrome".
Maybe that’s a sort of “belt and braces” approach? I don’t know. I have not had the time to look in great detail at the differences yet in the three files. The hybrid comes out the smallest of the three.
( https://i.postimg.cc/MK5Q4rYc/Hybrid-scrapping-code-gives-smallest-text-file.jpg ) )

Coding to get those 9 text files

Sub WieGehtsYouTubeURLServerChromeHybridStep75() ' https://eileenslounge.com/viewtopic.php?p=303644#p303644 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
With CreateObject("MSXML2.ServerXMLHTTP")
' .Open "GET", "https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'.Open "GET", "https://www.youtube.com/watch?v=4vcAvCLMyUY&list=UULFwInqvNXb-GN0JHdtoul_9A&index=1", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=NVaMcQcWLKc&list=UULFwInqvNXb-GN0JHdtoul_9A&index=76", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=8a0nYGk_DkE&list=UULFwInqvNXb-GN0JHdtoul_9A&index=151", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=4VreecmIQOY&list=UULFwInqvNXb-GN0JHdtoul_9A&index=226", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=WDCmlmylNm8&list=UULFwInqvNXb-GN0JHdtoul_9A&index=301", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=Pr2sS5p0wcE&list=UULFwInqvNXb-GN0JHdtoul_9A&index=376", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=ppJI61RNY0M&list=UULFwInqvNXb-GN0JHdtoul_9A&index=451", False ' '
'.Open "GET", "https://www.youtube.com/watch?v=RgMdq3uQNuM&list=UULFwInqvNXb-GN0JHdtoul_9A&index=526", False ' '
.Open "GET", "https://www.youtube.com/watch?v=YofVQq3VngI&list=UULFwInqvNXb-GN0JHdtoul_9A&index=601", False ' '
'.Open "GET", "", False ' '
'.Open "GET", "", 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 & "\" & "WieGehtsYouTubeServerChrome601" & ".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

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
' Dim sTitle As String
' Let sTitle = Split(Split(PageSrc, """title"":{""runs"":[{""text"":""")(1), """}]}")(0)
'
' Dim sViews As String
' Let sViews = Split(Split(PageSrc, """shortViewCount"":{""simpleText"":""")(1), """}}}")(0)

DocAElstein

09-29-2022, 01:33 PM

Part 2
Get the 4vcAvCLMyUY type bit for use in like https://www.youtube.com/watch?v=4vcAvCLMyUY
I decided to get out all 11 digit unique YouTube bits ( like WDCmlmylNm8 ) you have in a typical YouTube video link, like https://www.youtube.com/watch?v=WDCmlmylNm8
I find by inspection that there seems to be all these 11 digit unique YouTube bits, (sometimes duplicated**) in some text ending with like hqdefault.jpg. So that is what is looked for, then a bit of text manipulation is done to pick out the 11 digit unique YouTube bit

I used a macro like this next one, to get all the 11 digit bits from the 9 files got in the last post.

Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg() ' look fo this - hqdefault.jpg
Rem 0
Dim Ws1 As Worksheet: ' Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Set Ws1 = ThisWorkbook.Worksheets.Item("RoughNotes")
' Rem 1 Get the text file 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 & "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
If InStr(1, Unics, strURL, vbBinaryCompare) = 0 Then
Let Unics = Unics & " " & strURL
Dim Lr1 As Long: Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
Dim Nr As Long
If Ws1.Range("B1").Value = "" Then
Let Nr = 1
Else
Let Nr = Lr1 + 1
End If
Let Ws1.Range("B" & Nr & "").Value = strURL

Else ' Got a dup
Let Ws1.Range("C" & Nr & "").Value = Ws1.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
End Sub

That code above checks for duplicates of that 11 digit bit in each text file**, 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 )

That outputs to a spare sheet.
For now I manually copy that output 9 times and stick it all in column A of my main file, WieGehtsYouTube.xls ( https://app.box.com/s/97fnm2hhhbiwcnz4nte700pp9sqy79uy ).
https://i.postimg.cc/t47V7Gw8/Wie-Gehts-You-Tube-xls.jpg (https://postimages.org/)
(There are a few extra videos that seems to be advertisements or some video he recommends from someone else. Doesn’t matter – its obvious usually from the title wots wot. I also have the duplicates mentioned, but I take them out at the start of the next macro
I do it all like this for no special reason – its just the way it came out the first time as I went along. )

DocAElstein

09-29-2022, 01:33 PM

Part 3 How I got all the info I wanted
Main final macro
This went easier and smother than I thought it would.
And The final spreadsheet interaction coding isn’t that slow, - it’s still speed of light compared with doing it all manually, as I was. It’s actually nice to watch the spreadsheet filling up. Its fun when you think of the days of boring manual copying and pasting its saving and you get an initial check that the data looks sensible.
I don’t want to do this a thousand times a day for a year, - more like a few times a day for a couple of weeks. So I might stay with the slower novice code, - it’s easier to check and change. (It’s a bit cold though. I might put some clothes on. I don’t need to view this in my default skin).
There is not much point in explaining in detail how I manipulated the text file to get all the information I wanted. I expect if I did it a dozen times , forgetting every time how I did it the last time, then I would end up with as many different solutions. Just a matter of messing with string manipulation.

Code in the next post

One thing I did find nice is that Split Split stuff from Yasser. Maybe lots of people know about and use that. I saw it for the first time and it’s a very nice way to get a working coding to get stuff out of a big text file. Like…

jdhAJ Ex I want this Zed llmbldsm
So split by Ex , take second array element (1) from that
, then split the result by Zed and take the first element (0) of that
Simple but nice- I had always previously done some Instr Left Right Mid stuff before
So you can have a nice Pretty one line to start with,
Split(Split(PageSource, " ")(1), " ")(0)
Find what you are looking for, then drop in a bit of the stuff either side
= Split(Split(PageSource, " Ex ")(1), " Zed ")(0)

Sounds like a good one for a “YouTube short”

DocAElstein

10-02-2022, 06:21 PM

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

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

DocAElstein

10-02-2022, 06:21 PM

https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19703
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19703&viewfull=1#post19703 ???

Here is another go to update and take advantage of things learnt
….&index=1, &index=76, &index=151, &index=226 …. 301, 376,451,526,601
https://www.youtube.com/watch?v=Cy4_zrFja2w&list=UULFwInqvNXb-GN0JHdtoul_9A&index=1
https://www.youtube.com/watch?v=d_RO2VIcFYw&list=UULFwInqvNXb-GN0JHdtoul_9A&index=76
https://www.youtube.com/watch?v=gKNh43aEw_E&list=UULFwInqvNXb-GN0JHdtoul_9A&index=151
https://www.youtube.com/watch?v=JzU7jFWbA6s&list=UULFwInqvNXb-GN0JHdtoul_9A&index=226
https://www.youtube.com/watch?v=g_1_saf0E1I&list=UULFwInqvNXb-GN0JHdtoul_9A&index=301
https://www.youtube.com/watch?v=IAIESH9vPbk&list=UULFwInqvNXb-GN0JHdtoul_9A&index=376
https://www.youtube.com/watch?v=9u372_W07Nw&list=UULFwInqvNXb-GN0JHdtoul_9A&index=451
https://www.youtube.com/watch?v=6SDkQ-iMrC4&list=UULFwInqvNXb-GN0JHdtoul_9A&index=526
https://www.youtube.com/watch?v=EWr8G0r89k0&list=UULFwInqvNXb-GN0JHdtoul_9A&index=601

Option Explicit
Sub WieGehtsYouTubeURLServerChromeHybridStep75_2() ' 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 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 & "\" & "Videos(1)\" & "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

That last coding got the text files https://i.postimg.cc/G4t0CNL4/9-text-files.jpg (https://postimg.cc/G4t0CNL4)

The next macro needed little change other than the Folder in which the text files are, and the new worksheet used for this new attempt at getting all info from video playlist

' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19703
Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_Vide oPlayList() ' look for this - hqdefault.jpg
Rem 0a
Dim WsPop As Worksheet: Set WsPop = ThisWorkbook.Worksheets.Item("ElevenDigitYT(1)")
'Set Ws1 = ThisWorkbook.Worksheets.Item("RoughNotes")
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 & "Videos(1)\" & Txts(Cnt) ' "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 = WsPop.Range("A" & WsPop.Rows.Count & "").End(xlUp).Row
Dim Nr As Long
' If WsPop.Range("B1").Value = "" Then
' Let Nr = 1
' Else
Let Nr = Lr1 + 1
' End If
Let WsPop.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 ' ============================
End Sub
'_-__________________________________________________ __________________________________________________ _

DocAElstein

10-02-2022, 06:21 PM

Main Macro
The most important change I did here was to include extra Title changes mainly those of typical characters that I want to get rid of. This sort of thing

' 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, "-", " ", 1, -1, vbBinaryCompare)
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, "-", " ", 1, -1, vbBinaryCompare)
' Let Title = Replace(Title, "-", " ", 1, -1, vbBinaryCompare)
Let Title = Application.WorksheetFunction.Trim(Title) ' In case any spaces caused by removing stuff

Here the full current coding:

' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19704
Sub GetStuffFrom11DigitYouTube2() ' 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("ElevenDigitYT(1)")
Dim RngWsYT11 As Range: Set RngWsYT11 = WsYT11.Range("A1:A680") ' 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 = 500 To 680 ' 692
RngWsYT11.Item(Cnt).Select
'If RngWsYT11.Item(Cnt).Offset(0, 1).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 & "\Videos(1)\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)
' 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)
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

DocAElstein

10-02-2022, 06:21 PM

This is post #98 #post19705
https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=19705&viewfull=1#post19705 ???
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19705

Final video Folder Video order
I need to do some sorting. Order sorting, for example based on date, and / or add a date “stamp” …

The problem is that my final modified titles on the actual videos will not tie up perfectly with those got from the scrapping coding. (But I note here that as time goes on the two will get closer, as I tend to apply more and more adjusting at the initial scrapping level , based on the modifications later that I find I need to do )

I spent a few frustrating days trying to modify an efficient range.Find to do this, but it did not really do it without being very complicated so wasting the otherwise efficient way the range.Find seems to work.

Finally a simpler VBA array coding seems OK for now, so I need a Simple VBA arrays coding to match up two Title list where the Titles for a particular video may be slightly different in the two lists

VBA arrays coding to match up 2 slightly different Titles of same Video in 2 lists
The function takes in …
__ ( The value ( Title text ) to be looked for , the range (as range object) to be looked in ) returning the found cell as range object

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

Rem 1 This does some tidying of given Title text value to be looked for. This follows along the usual typical tidying up that I do of Titles, but as noted, as time goes on the two titles for the same video will get closer, as I tend to apply more and more adjusting at the initial scrapping level , based on the modifications later that I find I need to do

Rem 2 is a bit of a customized fiddle thing. This is because there is a chance the first few words would never be found, even later, as I might have had some number or other ordering text added at the start. So I make an adjustment fiddle thing and variable that means I don’t include those words. Its basically based on a quick more conventional Range.Find thing to see if the first word(s) are anywhere in the list. If not then from then on we never try those.

Rem 3 is the main searching Loop(s). Three of them, in a nested fashion.
_ The outer loop , loops backwards if necessary to reduce the number of words we try to find in a single title in the list to be searched for a match.
_ The next Loop inside is looping all the rows in the list of titles to be searched for a match
_ The inner most loop goes through all (or most depending on what happened in Rem 2 ) of the words from the title to be looked for, and if we reach the required number of hits, HitsWish , then we terminate after passing the found cell to the result of the function, This is the bit that does that…
Set TitlSrch = SrchClm.Item(Rw)
Here is the initial final macro, at this stage :

' 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
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
Let Application.EnableEvents = True
Rem 1 Some tidying of given string.
' 1a) This follows along the usual typical tyding up that I do of Titles
Dim SchTxt As String: Let SchTxt = Trim(TrgtVal) ' Trim(Trgt.Value)
' Initial check for if multi words if there are spaces
If InStr(1, SchTxt, " ", vbBinaryCompare) > 0 Then ' Check for more than 1 word to look for==============
' Remove all but single space in between words to allow split via a space
Let SchTxt = Evaluate("=TRIM(SUBSTITUTE(" & """" & SchTxt & """" & ",CHAR(160),CHAR(32)))") ' TRIM function trims the 7-bit ASCII space character (value 32). In the Unicode character set, there is an additional space character called the nonbreaking space character that has a decimal value of 160. This character is commonly used in Web pages as the HTML entity,  . By itself, the TRIM function does not remove this nonbreaking space character. https://www.excelforum.com/excel-formulas-and-functions/1217202-is-there-a-function-similar-to-trim-but-that-only-removes-trailing-spaces-2.html Note also that spaces more than 1 are removed from in between text
' Do some empirical text tidying up that I might typically have done in a final video title
Let SchTxt = Replace(SchTxt, "ä", "ae", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "ü", "ue", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "ö", "oe", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "Ä", "AE", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "Ü", "UE", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "Ö", "OE", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "-", " ", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "#wiegehtyoutube", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "!", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "?", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "ß", "ss", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "€", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, ":", " ", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "#", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "&", " ", 1, -1, vbBinaryCompare) '
Let SchTxt = Replace(SchTxt, "'", " ", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "‚", " ", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, """", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "“", " ", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "„", " ", 1, -1, vbBinaryCompare) ' „ajdffak“
Let SchTxt = Replace(SchTxt, "+", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, ".", "", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "YouTube", "UT", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "[", "(", 1, -1, vbBinaryCompare)
Let SchTxt = Replace(SchTxt, "]", ")", 1, -1, vbBinaryCompare)
' Let SchTxt = Replace(SchTxt, "-", " ", 1, -1, vbBinaryCompare)
' Let SchTxt = Replace(SchTxt, "-", " ", 1, -1, vbBinaryCompare)
' Let SchTxt = Replace(SchTxt, "-", " ", 1, -1, vbBinaryCompare)
' Let SchTxt = Replace(SchTxt, "-", " ", 1, -1, vbBinaryCompare)
' Let SchTxt = Replace(SchTxt, "-", " ", 1, -1, vbBinaryCompare)

' Let SchTxt = Replace(schtxt, "-", " ", 1, -1, vbBinaryCompare)
' Let SchTxt = Replace(schtxt, "-", " ", 1, -1, vbBinaryCompare)
Let SchTxt = Application.WorksheetFunction.Trim(SchTxt) ' In case any spaces caused by removing stuff, as we still just want one space between for splitting

Dim SchPts() As String: Let SchPts() = VBA.Strings.Split(SchTxt, " ", -1) ' Do split on single space to get multiple words
'1b) removing of some words, for example if they are very common, or small
Dim strNew As String
Dim Cnt As Long
For Cnt = LBound(SchPts()) To UBound(SchPts())
If Len(SchPts(Cnt)) < 5 Then
' ignore short words
Else
Select Case SchPts(Cnt)
Case "YouTube", "Youtube"
' ignore those words
Case Else
Let strNew = strNew & SchPts(Cnt) & " " ' Building string from any nmot ignored words
End Select
End If
Next Cnt
Let strNew = Left(strNew, Len(strNew) - 1) ' Take off last space
If InStr(1, strNew, " ", vbBinaryCompare) = 0 Then GoTo SS ' go to Look for just one word
Let SchPts() = VBA.Strings.Split(strNew, " ", -1)

Dim HitsWish As Long: Let HitsWish = 6 ' The most number of words we must find to make it as sucess before trying less words. Set this empirically

Rem 2 checking to find at least one word
Dim Adj As Long ' This is used to add to array index if first word was not found
For Cnt = 0 To UBound(SchPts())
Dim FndCel As Range ' used for result of any search
Set FndCel = SrchClm.Find(what:=SchPts(0 + Adj), LookIn:=xlFormulas, Lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If FndCel Is Nothing Then
Let Adj = Adj + 1
If Adj > UBound(SchPts()) Then MsgBox Prompt:="Cant find any words in " & vbCr & vbLf & """" & TrgtVal & """" & vbCr & vbLf & """" & strNew & """": Debug.Print "Cant find any words in " & vbCr & vbLf & """" & TrgtVal & """" & vbCr & vbLf & """" & strNew & """": GoTo TheEnd
Else
Exit For
End If
Next Cnt
If Adj = UBound(SchPts()) Then Let SchTxt = SchPts(UBound(SchPts())): GoTo SS ' We only got one word to look for, the last word in our array of words to look for, the only word that was found actually, so going to SS here means I will look for it again there, nevermind
' At this point we have at least two words and hopefully at least 4. Normally we would have a total of UBound(SchPts())+1. But this will be reduced by Adj
' If UBound(SchPts()) + 1 - Adj = 6 Then Let HitsWish = 6 ' We only have 6 words to search for
If UBound(SchPts()) + 1 - Adj = 5 Then Let HitsWish = 5 ' We only have 5 words to search for
If UBound(SchPts()) + 1 - Adj = 4 Then Let HitsWish = 4 ' We only have 4 words to search for
If UBound(SchPts()) + 1 - Adj = 3 Then Let HitsWish = 3 ' We only have three words to search for
If UBound(SchPts()) + 1 - Adj = 2 Then Let HitsWish = 2 ' We only have two words to search for

Rem 3 Check for Hits wanted, or less
Dim arrSrchClm() As Variant: Let arrSrchClm() = SrchClm.Value
Dim Hits
For Hits = HitsWish To 1 Step -1 ' If we dont jump out of the loop, then we reduce the hit cpount goal and try again
Dim Rw As Long
For Rw = 1 To UBound(arrSrchClm(), 1)
Dim CntHit As Long: Let CntHit = 0
For Cnt = 0 + Adj To UBound(SchPts())
If InStr(1, arrSrchClm(Rw, 1), SchPts(Cnt), vbBinaryCompare) > 0 Then
Let CntHit = CntHit + 1
If CntHit = Hits Then Debug.Print Hits & " Hits for """ & SrchClm.Item(Rw).Value & """": Set TitlSrch = SrchClm.Item(Rw): GoTo TheEnd
Else
End If
Next Cnt
Next Rw
Next Hits
Debug.Print "Nothing": Exit Function
SS: ' Do not put this before the Else idiot!
Set FndCel = SrchClm.Find(what:=VBA.Strings.Trim(SchTxt), LookIn:=xlFormulas, Lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False) ' I might sometimes be doing this twice. Nevermind
If Not FndCel Is Nothing Then
Set TitlSrch = FndCel: Let Hits = 1: GoTo TheEnd
Else
' Selection.Offset(0, 2).Select: GoTo TheEnd '''_- Exit Function ' case no single word match
End If
End If ' Finished case single word to look for or multiple words to look for=============================
TheEnd: '''_- Exit Function
' GoToEmptyCellNearby
Let Application.EnableEvents = True

EndFuk:
End Function

In the next post I will add some notes for the first few actual uses of that, ( and may then edit the above function coding a bit as I go along )

DocAElstein

10-02-2022, 06:21 PM

At the moment I have in a file , WieGehtsYouTube.xls , and the worksheet , "ElevenDigitYT(1)" , something close to all the videos from the Video Play list, and a few from the Popular Play list that did not appear in the Video PlayList.
https://i.postimg.cc/67ZhGRKV/Most-Videos-And-Some-Popular.jpg (https://postimg.cc/67ZhGRKV)
That should have close to all the actual videos in my main storage, which from a recent Dir thing gives me the Worksheet WMV

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

Coding discussed in the last post

' Second main coding

Sub GetStuffFrom11DigitYouTube2() ' 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("ElevenDigitYT(2)")
Dim RngWsYT11 As Range: Set RngWsYT11 = WsYT11.Range("A1:A692")
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 692
'If RngWsYT11.Item(Cnt).Offset(0, 1).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 & "\SecondAttemptPopular\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 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, 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

DocAElstein

10-02-2022, 06:21 PM

Popular / Video Playlists
At this stage of the proceedings I am interested to see if and what similarities in terms of the included videos in the two lists there are. ( I always noted that the number of videos always looks the same. )

Sub Find11digitUTbetween2lists() ' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19734
Rem 0 Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets("ElevenDigitYT"): Set Ws2 = ThisWorkbook.Worksheets("ElevenDigitYT(2)")
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = Ws1.Range("B2:B1027"): Set Rng2 = Ws2.Range("A2:A692")
Let Rng2.Value = Evaluate("=IF({1},LEFT(" & Rng2.Address & ",11))") ' reset the found rows or other info added
Rng2.Font.ColorIndex = xlAutomatic
Rem 1
Dim aCel As Range
For Each aCel In Rng2
Dim Fndit As Range
Set Fndit = Rng1.Find(What:=aCel.Value, After:=Rng1.Item(1026), LookIn:=xlValues, lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Fndit Is Nothing Then

Else
Let aCel.Value = aCel.Value & " " & Fndit.Row
aCel.Font.Color = vbGreen
End If
Next aCel
End Sub

There were not many missing, and most were missed probably as they were recent ones done after I did the original codings.
So I just manually went and downloaded some of those to add to all my downloaded files

DocAElstein

10-02-2022, 06:21 PM

<lkhdksljd

DocAElstein

10-02-2022, 06:21 PM

kdkladjkdj

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

<AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

Part 3 How I got all the info I wanted
Main final macro
This will be based on the last one, https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19712
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19712&viewfull=1#post19712
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10#post19702
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19702&viewfull=1#post19702 ?????

As I went along the last time I made some small modifications but it’s basically the same coding:

DocAElstein

10-02-2022, 06:21 PM

Page 11 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11

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

Post 19753 #101
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping/page11#19753
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping/page11#19753

Popular videos So geht YouTube
https://www.youtube.com/@SogehtYouTube/videos?view=0&sort=p&shelf_id=0
https://www.youtube.com/playlist?list=UULPwInqvNXb-GN0JHdtoul_9A

Unlisted
So geht YouTube
https://www.youtube.com/@SogehtYouTube
1 / 667 Play all

https://www.youtube.com/watch?v=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A
https://www.youtube.com/watch?v=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A&index=1
https://www.youtube.com/watch?v=h15o6YLzfqc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=76
https://www.youtube.com/watch?v=cYJxctyMO2s&list=UULPwInqvNXb-GN0JHdtoul_9A&index=151
https://www.youtube.com/watch?v=dcQNQP9i_WE&list=UULPwInqvNXb-GN0JHdtoul_9A&index=226
https://www.youtube.com/watch?v=FDg34qCE8-Y&list=UULPwInqvNXb-GN0JHdtoul_9A&index=301
https://www.youtube.com/watch?v=t_Xuqu6Rw2Q&list=UULPwInqvNXb-GN0JHdtoul_9A&index=376
https://www.youtube.com/watch?v=5DkjHTTqIPc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=451
https://www.youtube.com/watch?v=1tT7m5qAR4o&list=UULPwInqvNXb-GN0JHdtoul_9A&index=526
https://www.youtube.com/watch?v=g9kOyaXsJlk&list=UULPwInqvNXb-GN0JHdtoul_9A&index=601
https://www.youtube.com/watch?v=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A
https://www.youtube.com/watch?v=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A&index=1
https://www.youtube.com/watch?v=h15o6YLzfqc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=76
https://www.youtube.com/watch?v=cYJxctyMO2s&list=UULPwInqvNXb-GN0JHdtoul_9A&index=151
https://www.youtube.com/watch?v=dcQNQP9i_WE&list=UULPwInqvNXb-GN0JHdtoul_9A&index=226
https://www.youtube.com/watch?v=FDg34qCE8-Y&list=UULPwInqvNXb-GN0JHdtoul_9A&index=301
https://www.youtube.com/watch?v=t_Xuqu6Rw2Q&list=UULPwInqvNXb-GN0JHdtoul_9A&index=376
https://www.youtube.com/watch?v=5DkjHTTqIPc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=451
https://www.youtube.com/watch?v=1tT7m5qAR4o&list=UULPwInqvNXb-GN0JHdtoul_9A&index=526
https://www.youtube.com/watch?v=g9kOyaXsJlk&list=UULPwInqvNXb-GN0JHdtoul_9A&index=601

DocAElstein

10-02-2022, 06:21 PM

This post , #102 19741
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19741
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19741
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19741&viewfull=1#post19741
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19741&viewfull=1#post19741

Second attempt

Previously, and in my first attempt ( https://eileenslounge.com/viewtopic.php?p=303644#p303644 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page10 ) I looked at all Videos from channel So geht YouTube ( https://www.youtube.com/@SogehtYouTube )
In thus second attempt I will look at another play list from the same channel, Popular videos
I do note the number of videos is exactly the same as in Videos, so they may be the same … we will see.
( Some of this will be repeated text from the first attempt, with bits added. All a bit mixed up, but it’s just my own rough notes for later reference )…….
The previous story… ……….( https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19701&viewfull=1#post19701 ) ……………….
_ In the long play list I looked at it seems you only get a text file of all the stuff I want for a bit more than 75 videos at a time. This makes sense and ties up with the experience when you view manually in real time: The scroll box only goes up to on average a bit over the first 75.
https://i.postimg.cc/phX1XqkM/Only-get-79-vids-in-one-go.jpg (https://postimg.cc/phX1XqkM)

Scrapping that, or rather to say, playing around with the text file from the page source text from this

https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A ' -- main play list link
,give links of this form
https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A&index=1
https://www.youtube.com/watch?v=YsnmNoq6OTg&list=UULFwInqvNXb-GN0JHdtoul_9A&index=2
https://www.youtube.com/watch?v=KIx_8comGEc&list=UULFwInqvNXb-GN0JHdtoul_9A&index=3
…….. up to about &index=79
If you want the next chunk of videos, and a new text file of it all, you have to click on a video towards the bottom. ( https://i.postimg.cc/65L3ydNF/Click-towards-bottom-to-get-next-lot.jpg ) I thought I would keep stuff in some organized order, so tried getting all the text in a text file from these 9 links, the ones ending with &index=1, &index=76, &index=151, &index=226 …. 301, 376,451,526,601
That sort of worked…. Eventually…
_ I end up with 9 big text files to play with So that is sort of Part 1. I got now all the info I need, somewhere I expect, in those files… https://i.postimg.cc/R06JWCxf/9-Big-Server-Chrome-hybrid-text-files.jpg
https://i.postimg.cc/R3mZ8BFV/9-Big-Server-Chrome-hybrid-text-files.jpg (https://postimg.cc/R3mZ8BFV)

_ a small snag: Previously using the main link, https://www.youtube.com/watch?v=rM-CtC6cklI&list=UULFwInqvNXb-GN0JHdtoul_9A , gets the first 79 links and with the index number, which is not essential but useful to have. But use a link with the extra &index=123 and I can’t find or get the index number from those 9 text files. Could be hidden there somewhere. I can’t see it initially. Maybe later.
No matter, not so important
_ ( I am actually using initially a hybrid Yasser/ SpeakEasy suggestion code to get those. So
Object "MSXML2.ServerXMLHTTP"
and the
.setRequestHeader "User-Agent", "Chrome".
Maybe that’s a sort of “belt and braces” approach? I don’t know. I have not had the time to look in great detail at the differences yet in the three files. The hybrid comes out the smallest of the three.
( https://i.postimg.cc/MK5Q4rYc/Hybrid-scrapping-code-gives-smallest-text-file.jpg ) )
…………………………

The new second story:
I will loop this time all 9 links to get the text files, instead of re hard coding 9 times as I did the last time, ( but I will run the macro from the VB Editor in step F8 mode as usual initially. )

Here the files:https://i.postimg.cc/Q9sqxzfN/9-Text-Files.jpg (https://postimg.cc/Q9sqxzfN)

Coding to get those 9 text files

Sub WieGehtsYouTubeURLServerChromeHybridStep75_2() ' 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=l8TYMHlqlLM&list=UULPwInqvNXb-GN0JHdtoul_9A&index=1" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=h15o6YLzfqc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=76" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=cYJxctyMO2s&list=UULPwInqvNXb-GN0JHdtoul_9A&index=151" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=dcQNQP9i_WE&list=UULPwInqvNXb-GN0JHdtoul_9A&index=226" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=FDg34qCE8-Y&list=UULPwInqvNXb-GN0JHdtoul_9A&index=301" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=t_Xuqu6Rw2Q&list=UULPwInqvNXb-GN0JHdtoul_9A&index=376" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=5DkjHTTqIPc&list=UULPwInqvNXb-GN0JHdtoul_9A&index=451" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=1tT7m5qAR4o&list=UULPwInqvNXb-GN0JHdtoul_9A&index=526" & vbCr & vbLf & _
"https://www.youtube.com/watch?v=g9kOyaXsJlk&list=UULPwInqvNXb-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 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 & "\" & "SecondAttemptPopular\" & "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
' Dim sTitle As String
' Let sTitle = Split(Split(PageSrc, """title"":{""runs"":[{""text"":""")(1), """}]}")(0)
'
' Dim sViews As String
' Let sViews = Split(Split(PageSrc, """shortViewCount"":{""simpleText"":""")(1), """}}}")(0)

DocAElstein

10-02-2022, 06:21 PM

Post 103 #post19742
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19742
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19742

Part2
So I have the 9 text files, and similarly to the first attempt, ( https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19711&viewfull=1#post19711 ) and I will advance the coding a bit to loop all the text files.

So, as before I decide to get out all 11 digit unique YouTube bits ( like WDCmlmylNm8 ) you have in a typical YouTube video link, like https://www.youtube.com/watch?v=WDCmlmylNm8 .
I find by inspection that there seems to be all these 11 digit unique YouTube bits, (sometimes duplicated**) in some text ending with like hqdefault.jpg. So that is what is looked for, then a bit of text manipulation is done to pick out the 11 digit unique YouTube bit
The macro will, as before, check for duplicates of that 11 digit bit in each text file**, 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 ) (Edit Note: I noticed later that because of the looping in Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_Popu larPlayList() results in the first few duplicates not being added. )
Here the macro:

As I am advancing the coding with looping, I will go straight into the final output worksheet, in this case worksheet ElevenDigitYT(2) , (and as Edit noted, all final duplicates are automatically removed)

Here the macro:

' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#post19742
Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_Popu larPlayList() ' look for this - hqdefault.jpg
Rem 0a
Dim WsPop As Worksheet: Set WsPop = ThisWorkbook.Worksheets.Item("ElevenDigitYT(2)")
'Set Ws1 = ThisWorkbook.Worksheets.Item("RoughNotes")
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 & "SecondAttemptPopular\" & Txts(Cnt) ' "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
If InStr(1, Unics, strURL, vbBinaryCompare) = 0 Then
Let Unics = Unics & " " & strURL
Dim Lr1 As Long: Let Lr1 = WsPop.Range("A" & WsPop.Rows.Count & "").End(xlUp).Row
Dim Nr As Long
' If WsPop.Range("B1").Value = "" Then
' Let Nr = 1
' Else
Let Nr = Lr1 + 1
' End If
Let WsPop.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 ' ============================
End Sub

Here the results:
https://i.postimg.cc/D4nqYnQL/All-11-digit-unique-You-Tube-bits-from-hqdefault-jpg-for-all-9-text-files.jpg (https://postimg.cc/D4nqYnQL)4816

Simple macro to remove the duplicates in column A Edit: NOT NEEDED !!!
Previously this was done at the start of the main macro to get all the details I want from every video. But it’s a bit more tidier perhaps to do that quickly now, and put the unique values in column B
So I used this macro

Sub GetUnique11DigitYouTubeFromAandputinB()
Rem 0 Worksheets info
Dim WsPop As Worksheet: Set WsPop = ThisWorkbook.Worksheets.Item("ElevenDigitYT(2)")
Dim RngWsYT11 As Range: Set RngWsYT11 = WsPop.Range("A1:A692") ' 1008")
Dim Unics As String
Dim Cnt As Long
For Cnt = 2 To 692 ' 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 in column B empty
End If
Next Cnt
End Sub
But it did nothing!! – because of course, the looping in Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_Popu larPlayList() results in the first few duplicates not being added. Example at the start of the second main outer loop, the 76th 77th 78th and 79th would not get added
So I can forget that and take column A original to be all unique

DocAElstein

10-02-2022, 06:21 PM

Post 111 #post19743 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page12#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?list=PLipJz-fzcvQWvyJavhI12COqru03rchWt
), 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=nlZdIkipTIY&list=PLipJz-fzcvQWvyJavhI12COqru03rchWt
_ 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=nlZdIkipTIY&list=PLipJz-fzcvQWvyJavhI12COqru03rchWt&index=1
https://www.youtube.com/watch?v=nlZdIkipTIY&list=PLipJz-fzcvQWvyJavhI12COqru03rchWt&index=1

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.eileenslounge.com/viewtopic.php?p=296754#p296754 (https://www.eileenslounge.com/viewtopic.php?p=296754#p296754)
https://www.eileenslounge.com/viewtopic.php?p=296859#p296859 (https://www.eileenslounge.com/viewtopic.php?p=296859#p296859)
https://teylyn.com/2017/03/21/dollarsigns/#comment-191 (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/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.excelfox.com/forum/showthread.php/2355-Tests-and-Notes-on-Range-Referrencing/page8)
https://www.eileenslounge.com/viewtopic.php?p=296859#p296859 (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/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.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 (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

DocAElstein

10-02-2022, 06:21 PM

Coding follows along from before, ( https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#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-File-From-URLof-First-Video.jpg (https://postimg.cc/4nFVS37L) ,
___________________________________.... It was got from this macro

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

DocAElstein

10-02-2022, 06:21 PM

Post 113 #post19745 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page12#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/showthread.php/2840-Notes-tests-Scrapping-YouTube/page11#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

Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_Erst enShitPlayList() ' 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://postimg.cc/KRSSdjvG)

DocAElstein

10-02-2022, 06:21 PM

' https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page12#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

' 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://postimg.cc/7J4VKmb8) https://i.postimg.cc/T1L4Ys6w/Getting-Started.jpg (https://postimg.cc/7J4VKmb8)

DocAElstein

10-02-2022, 06:21 PM

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

'
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

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

Page 14 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page14
Post 131 #post19763 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page14#post19763
https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube?p=19763&viewfull=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=EEksPdEc7aI&list=PLlKpQrBME6xI-i6cL8Vdg2LOgjuawizcm&index=1

DocAElstein

10-02-2022, 06:21 PM

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

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 (https://postimg.cc/ZWj46Rnc)

DocAElstein

10-02-2022, 06:21 PM

#133 #post19765 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page14#post19765

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

Sub GetPlayListLinksFromTextFileUsinghqdefaultjpg_DavK ev() ' 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-Dev11-Digit-Bits-From6-Vid-Play-List.jpg (https://postimg.cc/TyS2tMHF)

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

DocAElstein

10-02-2022, 06:21 PM

#134 #post19766 https://excelfox.com/forum/showthread.php/2840-Notes-tests-Scrapping-YouTube/page14#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

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

DocAElstein

10-02-2022, 06:21 PM

Here is a wod

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

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

DocAElstein

10-02-2022, 06:21 PM

<lkhdksljd

DocAElstein

10-02-2022, 06:21 PM

This is post https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=19610&viewfull=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.php?p=303644#p303644
https://eileenslounge.com/viewtopic.php?p=303704#p303704

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

DocAElstein

10-02-2022, 06:21 PM

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

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

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

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

DocAElstein

10-02-2022, 06:21 PM

<lkhdksljd

DocAElstein

10-02-2022, 06:21 PM

This is post https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=19610&viewfull=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.php?p=303644#p303644
https://eileenslounge.com/viewtopic.php?p=303704#p303704

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

DocAElstein

10-02-2022, 06:21 PM

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

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

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

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

DocAElstein

10-02-2022, 06:21 PM

<lkhdksljd

DocAElstein

10-02-2022, 06:21 PM

This is post https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=19610&viewfull=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.php?p=303644#p303644
https://eileenslounge.com/viewtopic.php?p=303704#p303704

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

DocAElstein

10-02-2022, 06:21 PM

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

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

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

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

DocAElstein

10-02-2022, 06:21 PM

<lkhdksljd

DocAElstein

10-02-2022, 06:21 PM

This is post https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=19610&viewfull=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.php?p=303644#p303644
https://eileenslounge.com/viewtopic.php?p=303704#p303704

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

DocAElstein

10-02-2022, 06:21 PM

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

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

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha

DocAElstein

10-02-2022, 06:21 PM

ljdcsljd

DocAElstein

10-02-2022, 06:21 PM

AKJDakjdha