P2P Cloud DVR remote Access via a (remote) PC Using Guarding Vision PC Client Software

**DocAElstein** · 12-24-2018, 01:16 PM

Routine for following excelfox Thread
http://www.excelfox.com/forum/showth...0865#post10865

Code:

Sub TestieCall()
 Call PubeProFannyTeas__GLetner("23 12 2018")
End Sub
Sub PubeProFannyTeas__GLetner(ByVal strDte As String)
Rem 0 VBA project instantiated VBIDE
Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module
 Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodule                                                 ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module
Rem 1 This code module data range
'1a) get full data range as string
Dim Cnt As Long, Lr As Long, ReedLineIn As String
 Let Lr = VBIDEVBAProj.countoflines: Let Cnt = Lr + 1
    Do
     Let Cnt = Cnt - 1
     Let ReedLineIn = VBIDEVBAProj.Lines(StartLine:=Cnt, Count:=1)
    Loop While Not (Left(ReedLineIn, 7) = "End Sub" Or Left(ReedLineIn, 7) = "End Fun")
    If Cnt = Lr Then MsgBox Prompt:="No range data values in code module  " & VBIDEVBAProj.Name: Exit Sub
'1b) Complete data region as single string.
Dim strIn As String: Let strIn = VBIDEVBAProj.Lines(StartLine:=Cnt + 1, Count:=Lr - Cnt)
 Let strIn = Mid(strIn, 3) ' take off first vbCr & vbLf
 'WotchaGot (strIn)
'1c) split into date ranges, get most recent of any dates to match given  strDte
Dim DtedRngs() As String: Let DtedRngs() = Split(strIn, vbCr & vbLf & vbCr & vbLf) ' Split range by empty line which is double  vbCr & vbLf
 'WotchaGot (DtedRngs(0)): Debug.Print: WotchaGot (DtedRngs(1))
    For Cnt = UBound(DtedRngs()) To LBound(DtedRngs()) Step -1
    '1d)Check for date match, if so the main code working begins
        Dim FndDte As String: Let FndDte = Mid(DtedRngs(Cnt), 4, 10) ' looking at like this typical start of a data range,    '_-23 12 2018 Wo....  we see that 10 characters from character 4 will give us the date
        If FndDte = strDte Then
         'MsgBox Prompt:=FndDte
        Rem 2 manipulation of found date range
        Dim strRng As String: Let strRng = DtedRngs(Cnt)
         Let strRng = Mid(strRng, 27) 'takes off up to start of worksheet name... no speacial reason toher than why not? - its not needed anymore
        '2a) range info
        Dim RngInfo As String: Let RngInfo = Left(strRng, InStr(1, strRng, """)" & vbCr & vbLf, vbBinaryCompare) - 1) '    This gets us at like        Tabelle1").Range("$I$2513:$J$2514
        Dim ShtName As String, RngAdrs As String
         Let ShtName = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(0) '    split above string ,  using as seperator  ").Range("   ,  into 2 bits   ,   for exact computer binary type compare     Then we have first array element (indicie (0)) as the worksheet name  and the second array element (indicie (1)) as the range address
         Let RngAdrs = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(1) ': Debug.Print ShtName & "  " & RngAdrs
        Dim Ws As Worksheet, Rng As Range: Set Ws = Worksheets("" & ShtName & ""): Set Rng = Ws.Range(RngAdrs)
        '2b) get data value range
         Let strRng = Mid(strRng, InStr(1, strRng, vbCr & vbLf, vbBinaryCompare) + 2) ' take off first line & the first vbCr & vbLf
         Let strRng = Left(strRng, InStr(1, strRng, "'_- EOF ", vbBinaryCompare) - 1) ' take off last line, ( but leave on the vbCr & vbLf as that seems to typically be on a string from an excel range
         'WotchaGot strRng
         Let strRng = Replace(strRng, " | ", vbTab, 1, -1, vbBinaryCompare) 'Change code window cell wall seperator for that used by Excel
         Let strRng = Replace(strRng, "'_-", "", 1, -1, vbBinaryCompare)
         Let strRng = Replace(strRng, "  ", "", 1, -1, vbBinaryCompare) ' Bit of bodge to remove my added spaces
         'Debug.Print strRng
        Rem 3 output to worksheet
        Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): objDataObject.SetText strRng: objDataObject.PutInClipboard ' Text is given to Data object which in turn uses its method to put that in the clipboard
         Ws.Paste Destination:=Rng 'Worksheets Paste method with optional argument to determine where, ( default would be from top left of active range )
         Exit Sub 'This code only gets the first found range looking from code window bottom
        Else '     No matching date found yet, so do nothing but
        End If '    go on to
    Next Cnt '    next date range ' ( There is no check for no matching date. The code will simple end after all ranges have been looped through.)
End Sub

https://eileenslounge.com/viewtopic....320957#p320957

**DocAElstein** · 12-30-2018, 08:47 PM

Code for Yassser here:
http://www.eileenslounge.com/viewtop...=31529#p243999

Code:

Option Explicit
'I have numbers from 1 to 2319 made in groups in different numbers (in ten groups) as shown in column F
'How can I get random distribution for those group to have the same range of numbers from 1 to 2319
'but in different order and at the same time to have the same number inside each group
'Example
'Group 6 from 1267 - 1489 >> the number inside that group is 223
'Suppose the random choice make this group the first one so the expected result would be 1 - 223
'
'then suppose the second selected group is group 8 which is 1699 - 1938 >> the number inside that group is 240
'So that new group in the expected result would start at 224
'(which is the last number in the previous result and the finish number would be 463
'
'...
'Is it possible to do that in random order?
'
Sub RandomDistribution4Numbers() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31529
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1")
Dim arrSN() As Variant: Let arrSN() = Ws1.Range("F2:F" & Ws1.Range("F" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs
Dim LstGrpStp As Long: Let LstGrpStp = 0 ' last number used at end of random number group
Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To UBound(arrSN(), 1), 1 To 1) ' Array for output values
    Do ' we loop while we have not yet filled all of the output array, arrGrpsOut()
    Dim Rnd1ToUBnd As Long ' For a random array indicie from 1 to the UBound "row" of the input, (and output), arraysd
    Randomize: Let Rnd1ToUBnd = Int(UBound(arrSN(), 1) * Rnd) + 1
        If arrGrpsOut(Rnd1ToUBnd, 1) = "" Then ' Not yet filled this element in output array, so do the main stuff
        Dim OutElsFilled As Long: Let OutElsFilled = OutElsFilled + 1 ' count of number of outup array elements filled
        ' split F column (arrSN())  numbers to get range of numbers
        Dim SpltRng() As String: Let SpltRng() = Split(arrSN(Rnd1ToUBnd, 1), " - ", 2, vbBinaryCompare)
        Dim Rng As Long: Let Rng = SpltRng(1) - SpltRng(0) ' Range of numbers
        Dim Stt As Long, Stp As Long: Let Stt = LstGrpStp + 1: Let Stp = LstGrpStp + Rng + 1 ' Start and stop of range of numbers
        ' build output array with the numbers
         Let arrGrpsOut(Rnd1ToUBnd, 1) = Stt & " - " & Stp
         Let LstGrpStp = Stp ' Last highest used number
        Else ' If we come here then our random number must of been for an indicie of an array element already filled - so this probably makes the code a bit inefficient
        End If
    Loop While OutElsFilled < UBound(arrSN(), 1) ' we loop while we have not yet filled all of the output array, arrGrpsOut(), which is determined by if we did the main stuff as many times as there are elements in the input/Output arrays

 Let Ws1.Range("G2").Resize(UBound(arrSN(), 1)).Value = arrGrpsOut
End Sub
'





Sub RandomizeGroups() ' Hans code ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31529#p244006
    Dim arr   As Variant
    Dim lb    As Long
    Dim ub    As Long
    Dim i     As Long
    Dim j     As Long
    Dim tmp   As Long
    Dim n     As Long
    Dim idx() As Long
    Dim itm() As String
    Dim grp() As String
    arr = Range("F2:F11").Value
    lb = LBound(arr, 1)
    ub = UBound(arr, 1)
    ReDim idx(lb To ub)
    ReDim grp(lb To ub)
    For i = lb To ub
        idx(i) = i
    Next i
    For i = lb To ub
        j = Application.RandBetween(lb, ub)
        tmp = idx(i)
        idx(i) = idx(j)
        idx(j) = tmp
    Next i
    n = 1
    For i = lb To ub
        itm = Split(arr(idx(i), 1), " - ")
        grp(idx(i)) = n & " - " & n + itm(1) - itm(0)
        n = n + itm(1) - itm(0) + 1
    Next i
    Range("G2:G11").Value = Application.Transpose(grp)
End Sub

Typical results from my code are shown in column G. ( The code works on the data from column F )

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	E	F	G	H	I
1	for illustration	SN		Some expected result	Number inside Group
2	1	1 - 244	923 - 1166		244
3	2	245 - 448	1 - 204		204
4	3	449 - 750	398 - 699		302
5	4	751 - 1003	1879 - 2131		253
6	5	1004 - 1266	1167 - 1429		263
7	6	1267 - 1489	700 - 922	1 - 223	223
8	7	1490 - 1698	1430 - 1638		209
9	8	1699 - 1938	1639 - 1878	224 - 463	240
10	9	1939 - 2126	2132 - 2319		188
11	10	2127 - 2319	205 - 397		193

Worksheet: Sheet1

here below a few more runs, showing just column G
_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	G
1
2	591 - 834
3	835 - 1038
4	1502 - 1803
5	2067 - 2319
6	1804 - 2066
7	1279 - 1501
8	382 - 590
9	1039 - 1278
10	194 - 381
11	1 - 193

Worksheet: Sheet1

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

254 - 497	2076 - 2319	1470 - 1713	638 - 881
498 - 701	517 - 720	1923 - 2126	1 - 204
1174 - 1475	1774 - 2075	705 - 1006	2018 - 2319
1 - 253	264 - 516	264 - 516	1354 - 1606
911 - 1173	1 - 263	1 - 263	882 - 1144
1476 - 1698	1551 - 1773	1247 - 1469	1607 - 1829
702 - 910	1342 - 1550	1714 - 1922	1145 - 1353
1892 - 2131	721 - 960	1007 - 1246	205 - 444
2132 - 2319	1154 - 1341	517 - 704	1830 - 2017
1699 - 1891	961 - 1153	2127 - 2319	445 - 637

Worksheet: Sheet1

**DocAElstein** · 12-31-2018, 12:43 AM

Code:

'

Sub Populatenumbersfromrangeofnumbers2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31531&p=244015#p244015
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1")
Dim arrSN() As Variant: Let arrSN() = Ws1.Range("F2:F" & Ws1.Range("F" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs
Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To 1) ' 1 Dimensional  Array for output values.
Dim cnt As Long, Cnt2 As Long, Rng2 As Long, Rng1 As Long, Rws As Long
    For cnt = LBound(arrSN(), 1) To UBound(arrSN(), 1)
    Dim SpltRng() As String: Let SpltRng() = Split(arrSN(cnt, 1), " - ", 2, vbBinaryCompare)
    Dim arrRws() As Variant 'Array for 1 2 3 4 5 6 7 etc
     Let arrRws() = Evaluate("=row(" & SpltRng(0) & ":" & SpltRng(1) & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between the ranges
     Let Rng1 = UBound(arrGrpsOut()) + 1 ' The start of a range must be just above the last one
     Let Rng2 = Rng1 + SpltRng(1) - SpltRng(0) ' 'this gives the top of the current range in indicies of arrGrpsOut()
     ReDim Preserve arrGrpsOut(1 To Rng2)
        For Cnt2 = Rng1 To Rng2
         Let arrGrpsOut(Cnt2) = arrRws(Cnt2 - Rng1 + 1, 1) ' Cnt2 is the indicie in arrGrpsOut(), for the indicie in arrRws() we need to start at 1, then 2 3 4 5
        Next Cnt2
    Next cnt

Dim arrOut() As String: ReDim arrOut(1 To UBound(arrGrpsOut()) - 1, 1 To 1) ' a 2 dimension, 1 column , to be easy to post the results of this array into a column
    For cnt = 1 To UBound(arrGrpsOut()) - 1
     Let arrOut(cnt, 1) = arrGrpsOut(cnt + 1)
    Next cnt

 Let Ws1.Range("K2").Resize(UBound(arrOut(), 1), 1) = arrOut()
End Sub
Sub Populatenumbersfromrangeofnumbers2_2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31531&p=244015#p244015
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1")
Dim arrSN() As Variant: Let arrSN() = Ws1.Range("G2:G" & Ws1.Range("G" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs
Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To 1) ' 1 Dimensional  Array for output values.
Dim cnt As Long, Cnt2 As Long, Rng2 As Long, Rng1 As Long, Rws As Long
    For cnt = LBound(arrSN(), 1) To UBound(arrSN(), 1)
    Dim SpltRng() As String: Let SpltRng() = Split(arrSN(cnt, 1), " - ", 2, vbBinaryCompare)
    Dim arrRws() As Variant 'Array for 1 2 3 4 5 6 7 etc
     Let arrRws() = Evaluate("=row(" & SpltRng(0) & ":" & SpltRng(1) & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between the ranges
     Let Rng1 = UBound(arrGrpsOut()) + 1 ' The start of a range must be just above the last one
     Let Rng2 = Rng1 + SpltRng(1) - SpltRng(0) ' 'this gives the top of the current range in indicies of arrGrpsOut()
     ReDim Preserve arrGrpsOut(1 To Rng2)
        For Cnt2 = Rng1 To Rng2
         Let arrGrpsOut(Cnt2) = arrRws(Cnt2 - Rng1 + 1, 1) ' Cnt2 is the indicie in arrGrpsOut(), for the indicie in arrRws() we need to start at 1, then 2 3 4 5
        Next Cnt2
    Next cnt

Dim arrOut() As String: ReDim arrOut(1 To UBound(arrGrpsOut()) - 1, 1 To 1) ' a 2 dimension, 1 column , to be easy to post the results of this array into a column
    For cnt = 1 To UBound(arrGrpsOut()) - 1
     Let arrOut(cnt, 1) = arrGrpsOut(cnt + 1)
    Next cnt

 Let Ws1.Range("L2").Resize(UBound(arrOut(), 1), 1) = arrOut()
End Sub

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

SN		Some expected result	Number inside Group
1 - 244	1600 - 1843		244	1	1600
245 - 448	700 - 903		204	2	1601
449 - 750	398 - 699		302	3	1602
751 - 1003	1844 - 2096		253	4	1603
1004 - 1266	1144 - 1406		263	5	1604
1267 - 1489	2097 - 2319	1 - 223	223	6	1605
1490 - 1698	189 - 397		209	7	1606
1699 - 1938	904 - 1143	224 - 463	240	8	1607
1939 - 2126	1 - 188		188	9	1608
2127 - 2319	1407 - 1599		193	10	1609
			2319	11	1610
				12	1611
				13	1612
				14	1613
				15	1614
				16	1615
				17	1616
				18	1617
				19	1618
				20	1619
				21	1620
				22	1621
				23	1622
				24	1623
				25	1624
				26	1625
				27	1626
				28	1627
				29	1628
				30	1629
				31	1630
				32	1631
				33	1632
				34	1633

Worksheet: Sheet1

FinalKandLColumns.JPG : https://imgur.com/NF6f2vL
Attachment 2124

**DocAElstein** · 01-01-2019, 07:41 PM

Code for suppot of this Thread:
http://eileenslounge.com/viewtopic.php?f=30&t=31540

Code:

Sub SpltTests()
 Call Splt(1, 244, 1377, 1620)
End Sub
Function Splt(ByVal N1a As Long, ByVal N1b As Long, ByVal N2a As Long, ByVal N2b As Long) As Variant ' Variant as I don't know yet what might be wanted as output
Rem 1 full columns of data - full data arrays
Dim Clm1() As Variant: Let Clm1() = Evaluate("=row(" & N1a & ":" & N1b & ")")  ' This returns a one "column" 2 Dimensional array of all the numbers between N a and N b
Dim Clm2() As Variant: Let Clm2() = Evaluate("=row(" & N2a & ":" & N2b & ")")
Rem 2 get total number of arrays needed
Dim En As Long ' We want
 Let En = Int(((N1b - N1a) + 1) / 40) + 1
Rem 3a Not so simple maths to get some grouped numbers for top left of output arrays
' I need rows 1,1,1,42,42,42,83, columns 1,4,7,1,4,7,1
Dim ltrEn As String: Let ltrEn = Cltr(En) ' column letter from column number - G in example data
Dim ltrEnPlus3 As String: Let ltrEnPlus3 = Cltr(En + 3)
Dim Rws() As Variant ' row co ordinates of outout arrays
 Let Rws() = Evaluate("=Index((int((column(D:" & ltrEnPlus3 & ")-1)/3)),)") ' Evaluate("=Index((int((column(D:J)-1)/3)),)") 'returns {1, 1, 1, 2, 2, 2, 3}
Dim Clms() As Variant ' column co ordinates of output arrays
 Let Clms() = Evaluate("=Index((mod(column(A:" & ltrEn & ")-1,3)+1),)") ' Evaluate("=Index((mod(column(A:G)-1,3)+1),)") 'Returns { 1, 2, 3, 1,  2, 3, 1 }
Dim Cnt '  Loop for all data sections ==================================================
    For Cnt = 1 To En
    Rem 3b Top left for each array
    Dim rTL As Long, cTL As Long
     Let rTL = ((Rws(Cnt) - 1) * 41) + 1 ' In the looping this will give 1,1,1,42,42,42,83
     Let cTL = ((Clms(Cnt) - 1) * 3) + 1 ' In the looping this will give 1,4,7,1,4,7,1
    Rem 4 Columns of data for each loop
    Dim ClmOut1() As Variant, ClmOut2() As Variant '4a) use Index with arrays to get part of the sections from full data arrays
     Let ClmOut1() = Application.Index(Clm1(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 1
     Let ClmOut2() = Application.Index(Clm2(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 2
    Dim ClmOut1_1(1 To 40, 1 To 1) As Variant, ClmOut2_1(1 To 40, 1 To 1) As Variant ' I need Variant so as to get empty back for last array in loop paste out
    Dim Cnt2 As Long '4b) Loop to get convenient for output   2 dimensional 1 column arrays
        For Cnt2 = 1 To 40
            If IsError(ClmOut1(Cnt2)) Then Exit For ' To stop filling last array for large than top range value
         Let ClmOut1_1(Cnt2, 1) = ClmOut1(Cnt2) ' column 1
         Let ClmOut2_1(Cnt2, 1) = ClmOut2(Cnt2) ' column 2
        Next Cnt2
    Rem 5 Output of arrays to worksheet
    '5a Title
    Dim Tital(1 To 1, 1 To 2) As String: Let Tital(1, 1) = "S1": Let Tital(1, 2) = "S2"
    '5b Columns of data
    Dim WsRes As Worksheet: Set WsRes = Worksheets("Result")
     WsRes.Cells.Item(rTL, cTL).Resize(1, 2).Value = Tital() ' Title
     WsRes.Cells.Item(rTL + 1, cTL).Resize(40, 1).Value = ClmOut1_1() ' column 1
     WsRes.Cells.Item(rTL + 1, cTL + 1).Resize(40, 1).Value = ClmOut2_1() 'column 2
     Erase ClmOut1_1(), ClmOut2_1() ' without doing this out last array will not have any empties in it
    Next Cnt ' =============================================================================
End Function

' Column letter  http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Function Cltr(ByVal lclm As Long) As String 'Using chr function and Do while loop      For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
    Do
     Let Cltr = Chr(65 + (((lclm - 1) Mod 26))) & Cltr
     Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
    Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
'Dim arr1_40() As Variant: Let arr1_40() = Evaluate("=column(A:AN)") ' {1, 2, 3 ....40}

_.__________________________

It will take numbers like 1, 244, 1377, 1620 and then give your wanted result (I think, like Hans said, your test data is a bit wrong – check your row 82 should be 83 I think )
The function is hard coded inside for 40 data rows, and 3 columns of Result data, but you could easily adapt that for different numbers
Rem 1 gives the entire 2 columns of results , similar to in some of your last Threads. Full data arrays are got here for the ranges, ( in your example 1 - 244 and 1377 – 1620 )

Rem 2 does some simple maths to get the number of final sections, ( 7 in your example )

Rem 3 does some not so simple maths to get
row and column, Top left indices,
rTL and cTL , of where the output should go. You want
1,1,1,42,42,42,83 and 1,4,7,1,4,7,1

Rem 4 Uses Index( arrIn() , {1,2,3,4 } , 0 ) type stuff that you know about for pulling out part of an array to get the data section columns of data

Rem 5 Pastes out to the worksheet

Alan

Typical Output as seen in the next 2 posts,

**DocAElstein** · 01-01-2019, 07:49 PM

First 3 section output after running Sub SpltTests() from last post ( http://www.excelfox.com/forum/showth...0881#post10881 , https://tinyurl.com/yd95w5v2 )

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	A	B	D	E	G	H
1	S1	S2	S1	S2	S1	S2
2	1	1377	41	1417	81	1457
3	2	1378	42	1418	82	1458
4	3	1379	43	1419	83	1459
5	4	1380	44	1420	84	1460
6	5	1381	45	1421	85	1461
7	6	1382	46	1422	86	1462
8	7	1383	47	1423	87	1463
9	8	1384	48	1424	88	1464
10	9	1385	49	1425	89	1465
11	10	1386	50	1426	90	1466
12	11	1387	51	1427	91	1467
13	12	1388	52	1428	92	1468
14	13	1389	53	1429	93	1469
15	14	1390	54	1430	94	1470
16	15	1391	55	1431	95	1471
17	16	1392	56	1432	96	1472
18	17	1393	57	1433	97	1473
19	18	1394	58	1434	98	1474
20	19	1395	59	1435	99	1475
21	20	1396	60	1436	100	1476
22	21	1397	61	1437	101	1477
23	22	1398	62	1438	102	1478
24	23	1399	63	1439	103	1479
25	24	1400	64	1440	104	1480
26	25	1401	65	1441	105	1481
27	26	1402	66	1442	106	1482
28	27	1403	67	1443	107	1483
29	28	1404	68	1444	108	1484
30	29	1405	69	1445	109	1485
31	30	1406	70	1446	110	1486
32	31	1407	71	1447	111	1487
33	32	1408	72	1448	112	1488
34	33	1409	73	1449	113	1489
35	34	1410	74	1450	114	1490
36	35	1411	75	1451	115	1491
37	36	1412	76	1452	116	1492
38	37	1413	77	1453	117	1493
39	38	1414	78	1454	118	1494
40	39	1415	79	1455	119	1495
41	40	1416	80	1456	120	1496
42	S1	S2	S1	S2	S1	S2
43	121	1497	161	1537	201	1577

Worksheet: Result

**DocAElstein** · 01-01-2019, 07:51 PM

**DocAElstein** · 01-09-2019, 09:11 PM

Main Routine in support of these Threads Part 1
http://www.excelfox.com/forum/showth...0893#post10893
http://www.eileenslounge.com/viewtopic.php?f=21&t=31572

The coding is split into 2 parts to fil it into a Forum Post. But this and the coding in the next post form a single routine. That forms the main routine. In addition, a routine Called by the Main routine is required, Public Sub GetElemsText( ) , which is posted in the over next post.

Code:

Option Explicit
Sub EP() ' http://www.excelforum.com/showthread.php?t=1148621&page=7&p=4452110&highlight=#post4452110
Rem 1)File Info
'Dim wsLkUp As Worksheet: Set wsLkUp = ThisWorkbook.Worksheets("Tabelle1"): wsLkUp.Activate
Dim strURL As String ' File with Page ' file:///G:/Excel0202015Jan2016/OffenFragensForums/eileenslounge/XP/Updates/report.html
Let strURL = ThisWorkbook.Path & "\Updates\" & "report.html" ' '"http://www.ernaehrung.de/lebensmittel/de/W233000/Fleischkaese.php" ' "http://www.ernaehrung.de/lebensmittel/de/W233000/PloppyPooFukYou"
' Application.Wait Now + TimeValue("00:00:02") '
Rem 2) '
'2a xmlHTTP stuff MSXML2.XMLHTTP.6.0 IXMLHTTPRequest Alan: "simple xml request here, so you could give URL a simple File of the HTML code" 'Dim Request As Object: Set Request = CreateObject("MSXML2.XMLHTTP") 'Late Inding https://msdn.microsoft.com/en-us/library/ms759148(v=vs.85).aspx
Dim request As MSXML2.XMLHTTP: Set request = New MSXML2.XMLHTTP 'Early Binding Requires --- TOOLS --- REFERENCES -- tick Microsoft XML, v6.0 http://www.mrexcel.com/forum/excel-questions/759592-help-createobject-msxml2-xmlhttp-macro.html
'Application.Cursor = xlWait'cursor disable..just to be on the safe side???
With request '(or With CreateObject("msxml2.xmlhttp"))'By virtue of GET this is a simplified "xml" request
.Open bstrmethod:="GET", bstrURL:=strURL, varasync:=True ' ("GET", strURL, True) 'just preparing the request type, how and what type. The second argument determines type. This may then require further info in next lines Only diferrence to pike's and Kyle's opening and sending stuff is argument:- Leith: "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. I prefer to use asynchronous mode and test if my timeout period has expired to prevent the code from hanging due to an unresponsive server. In the example I provided I used synchronous mode to reduce the amount the code and keep it easier to understand."
'No extra info here for type GET ' ' '.setRequestHeader "DNT", "1"
'.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" ' Content-Type is the property name, x-www-form-urlencoded is the value (content type in the html is "text/html" not "x-www-form-urlencoded" - that is something diifferent) You can have different request header properties and pass different values. This isn't unusual, just not required in this case When you POST data to a server, you need to tell it what format you are sending it in. So the Type of Content sent in the body of the request (the send bit) is application/x-www-form-urlencoded
.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
.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
Set request = Nothing ' This section is finished. We no longer need the Library. Optionally can therefore Set request = Nothing, a step most appropriate if required for some reason. Previous arguments of good practice to prevent memory leaks and data corruption appear outdated in favour of only using when a good reason is apparent to avoid masking when it is a good idea.
'_..EP2ab Explicit Pedantry. We intend using PagrSrc through a method to produce a model Object Orientated stylio for later use through use of its Methods and Properties. This model is frequently referred to as a Document Orientated Model, DOM. Some steps in this creation of the "DOM" can frequently be confused with the processes in '2a which are in fact now finished. Part of the .Send , "finishes all processes. We move on to '2b. Only PagrSrc is required to be "taken over" as it were
'2b DOM stuff' Make OOP type model of HTML code, using Microsoft HTML Office Library
'Dim HTMLdoc As HTMLDocument: Set HTMLdoc = New HTMLDocument 'Early binding - will not work with .Write:- Leith "This is a case where late binding has to be used. The htmlfile is an ActiveX object that is a wrapper function for the IHTMLDocument2 interface in MSXML2. This gets into a lot of low level system operation......." https://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-vba-2.html#post4031122 https://www.excelforum.com/excel-programming-vba-macros/1214789-late-binding-2.html#post4820307 'Early binding TOOLS >>> REFERENCES >>Microsoft HTML Object Library
Dim HTMLdoc As Object: Set HTMLdoc = CreateObject("htmlfile") 'Late Binding, ' Create an empty HTML Document.
HTMLdoc.Open 'EP2b(i) This clears the values in the HTMLdoc. Complete Explicit Pedantry. in usage outside VBA, Methods for an instance will often be required which require a clearing of an instance before "using". Approximately in VBA this can be considered putting the DOM back to as if it were at the point just before it is given "loaded" with the PageSrc String. Effectively in VBA doing a pair of Set = Nothing , with either a Dim and Create Dom or Set = New type code line It serves no purpose usually in VBA. Effectively we reset a situation back to as it is. It can however be used through .Open
HTMLdoc.Write PageSrc 'EP2b(ii). Convert the HTML code into an HTML Document Object Model, DOM 'give it somehow the info it needs to work further? ---- Fills the DOM HTML .. Wiki Dom http://www.excelforum.com/showthread.php?t=1148621&page=3#post4441761
'HTMLdoc.body.innerHTML = PageSrc ' Most people do that, but The Write method of an HTML file is designed to convert the page source text into an HTML DOM document. Both methods achieve the same results. The more common way Body of the Page Source code when converting it to an HTML DOM document oustside of VBA. Withiin VBA it just works harder to achieve the same. This excludes the Meta data, Java scripts, and Class information from being converted. Generally speaking, this information is not used when retrieving only text data from a web page.
HTMLdoc.Close 'EP2b(iii) _ 2 b or not in 2b , that was the ?? http://www.excelforum.com/showthread.php?t=1148621&page=6.. Briefly When used outside VBA, some processes started by .Open() can or should be finished after the corresponding outside VBA .write(). This is done using .Close(). Once again this can be used in VBA through .Close. It has no conceivable merit or known as yet reason to use it in VBA. Pike thinks it It closes the document you have just written. As such he describes it as optional. He would also not have the HTMLdoc.Open. Kyle thinks nothing is open. Leith uses it but has made no comment to Date. This may be just his style, like my EP's just not including the HTMLdoc.Open 'EP2b(i)
Rem 3
Rem 3a) Directly

**DocAElstein** · 01-09-2019, 09:27 PM

Part 2 of Main code.
This coding in this post should be copied diretly under the coding from the last post. Together they form a single routine, the Main routine

(The routine, Public Sub GetElemsText( ) , which is posted in the next post is also required for the Main routine to work )

Code:

Rem 3a) Directly
'
'
'     Simple text file print out using just result of  PageSrc   from '2a
     Debug.Print PageSrc ' unfortunately you will unlikely be able to view the whole String as it appears too big. Also pasting to a cell will not make it all visible. However if after pasting the .value from the cell is put in a string and that used in place of Pagesrc in the creation of the DOM it does work, so indicating that the data is there, but just not possible for us to "see".
    Dim strTextFile As String: Let strTextFile = ThisWorkbook.Path & "\Updates\strTextFile.txt"
    Dim HghWyNo2 As Long: Let HghWyNo2 = FreeFile(RangeNumber:=1)
     Open strTextFile For Binary As #HghWyNo2
     Put #HghWyNo2, 1, PageSrc '  Use Put to write the whole array at once  http://www.vb-helper.com/howto_read_write_binary_file.html   https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/put-statement
     Close HghWyNo2
'
'
'
'Application.Cursor = xlDefault' Restore the cursor to normal.
Rem 3b) Large Object from main made OOP type model object, (HTMLdoc)    ( Rem 3b)(i) )          ' Dim Head As Object
'Dim Head As IHTMLElementCollection 'requires Early Binding. getElementsBy___ returns a NodeList which is an interface to the DispHTMLElementCollection which is an internal class that you're not supposed to see/use. It does implement the IHTMLElementCollection though so you can use that.
Dim Head As Object ' Unusually this Large main Object is Dim ed as an Object, ..as you find you cannot Dim it as what its TypeName( ) returns ( or as displayed in the Watch Window ), “DispHTMLElementCollection“ .
 Set Head = HTMLdoc.getElementsByTagName("Table") 'This Object is a massive thing again with loads in, but this time it would appear to be the things "tagged" with < table >  < /table > which look like the headings of each table I am interested in
Rem 4)(Rem 3b)(ii)) Often we would loop here for each "Table" but in our example we only have one
'Dim oTable  As THMLTable ' If we had Early binding, then this would work, because omehow  Head  has been recognised as a table   oTable as HTMLTable.JPG : https://imgur.com/R309JjC , and for ..._
Dim oTable  As Object ' _... this table we have typically present in the object  ' HTML TableRow count , "column" Count for final Table will need to be calculated, "HTML Cell" count in Entire Table
Dim C As Long, r As Long 'Indicies for getting appropriate Row and HTMLTableCell
'Dim n As Long ' Not needed if only one table so only "1 Loop"
'4b)=== main working would be Outer loop for each Table in many similar routines==============Building Array from HTML Table
'For n = 0 To Head.Length - 1 ' We only have one table so don't need to loop. The word Length in HTML things is often similar to what Count is in many VBA objects
 Set oTable = Head(0) ' Somehow  Head  has been recognised as a table   oTable as HTMLTable.JPG : https://imgur.com/R309JjC
'4b(i) Fill variable for dimensions variable for each, one on our case, Main loop
Dim rowCnt As Long: Let rowCnt = oTable.Rows.Length  ' "length" / number of rows in this table
Dim colCt As Long:  Let colCt = oTable.Cells.Length 'In this object the cells "length" would appear to be the number / count of cells in the entire table
Dim colCnt As Long: Let colCnt = Application.WorksheetFunction.RoundUp((colCt / oTable.Rows.Length), 0) ' 'This rounds up to the nearest avarage row width, that is to say column number in a row  '   I thought this did ? colCt \ oTable.Rows.Length
Dim Data() As String 'Array with string element used for output table. Fixed (static) String type for Text.
     ReDim Data(0 To rowCnt - 1, 0 To colCnt - 1) 'Output Array, reDimed to table being looked at. ( Hopefully always same column number, might want to hard Code to  rowCnt, 11 columns . Because I am using "base" of indicie to start at 0 then I go from 0 to one less than the Count(Length)
'4b(ii)  Looping through rows to build output array-----------|
'---Inner loop does at each row, ....
        For r = 0 To rowCnt - 1 'Going along the HTML Table rows exactly as pike ' https://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-vba.html#post4026613
'--- .... 'go through each Cell( "column" )  in that row.
            For C = 0 To colCnt - 1 'Going along the HTML Table Cells (columns) exactly the same as pike
'4b(ii)a Build Output Array
             Call GetElemsText(oTable.Rows(r).Cells(C), Data(r, C))   'Data(r, c) = oTable.Rows(r).Cells(c).innerText '  pike, kyle type alternative to calling sub
'4b(ii)b "post processing last column of unified units. ' Probably bad place to put this, other than Speed.. checking / changing units
'                If C = .....
'
'                Else
'                End If
            Next C
'--- .... 'go to next "Cell" in that table row (next Column we "see" in the table row)
        Next r
'---  'Go to next row in this table----------------------------|
'4b(ii)c  Output from Array
 Let Range("A1").Resize(UBound(Data(), 1) + 1, UBound(Data(), 2) + 1).Value = Data()
 Columns("A:Z").AutoFit
'Next n 'go back with a new item, n in large collection Object(item) to get next object within and start checking that one out.
'Go to the next table====
Set HTMLdoc = Nothing ' If done then  when we no longer need it
End Sub '

**DocAElstein** · 01-09-2019, 09:29 PM

This is required for the single Main routine which is posted in two parts in the last two posts

[Code]'2 Alan http://www.excelforum.com/showthread.php?t=1148621&page=3#post4441761
'5 Leith Ross http://www.mrexcel.com/forum/excel-questions/367030-copy-table-website-into-excel-visual-basic-applications-2.html#post4031122
'10 '....' "This is a recursive procedure to extract text from between an element's start tag and end tag and everything in between. Usually the Calling program will have passed a HTML code ( either from, for example, a .HTML File, a .Tex File, a .txt file, or from a returned such file after a request to a web page) into a Document Object Model. ( DOM ). This somehow organises things in a tree type structure , approximately as like you might see if you carefully indented the HTML code yourself, such that tag pairs were clear to see within tag pairs, each level down as it were. ( a "next level down" is often referred to as a "Child" ). The exact structure is less obvious, but in any case the DOM will have some ordered structure and every constitute part of the code is referred to as an Element. In a simple case most Elements have a start and stop pointed bracket. They are all nodes. Text is usually squeezed in between somewhere within a paired tag set, but is also referred to as a node.
'12 'I think a node is a point, usually a junction point in the tree type structure. Usually before the procedure is run a first time, an Element will have been obtained from the DOM and this is to be passed in the signature line of the procedure, as an Object. VBA then makes a Copy of the procedure and runs that with the given Element.
'15 'The macro will examine this Element Object brought in for a Text Node: If the element .NodeType is not 3 (a text node) then there are possibly child nodes ( Nodes "next down" in a Tree type listing ) that need to examined. The procedure then "Calls itself". In other words the first Copy stops at the Call Point. At the Call point another Copy of the procedure is made and runs in a loop for each child node.
'20 'The next Copy of the macro will again examine the element for a Text Node. If found (If element node type is 3), the text is concatenated with the ElemText String. If this is the ElemText string is empty then ElemText is set to this value. If not then this value is concatenated with any previous text and separated by a tilde character. This character can be used later to parse the text string into the individual strings from each element. The macro will exit the Sub at this point. When this happens, this copy of the macro is "removed from the call stack", in other words it Ends, and the last Copy continues from the Call point at which it was stopped.
Public Sub GetElemsText(ByRef Elem As Object, ByRef ElemText As String) 'It takes an Object, (variable Elem), a HTML Element, or a ( child ) node thereof. (Wiki says "An HTML element is an individual component of an HTML document or web page, once this has been parsed into the Document Object Model. (DOM). HTML is composed of a tree of HTML Elements and other nodes, such as text nodes." May be close to but not excactly what you se by carefully indenting down "Child" levels
'25 Dim strobjElem As String: Let strobjElem = TypeName(Elem)' http://www.excelforum.com/excel-programming-vba-macros/1149427-vba-determine-object-type-from-html-dom-object-put-type-in-string-variable-as-shown-in.html
65 Rem 1) Do we have an Element
70 If Elem Is Nothing Then GoTo LEndSub [color=darkgreen]'If the Object Elem is empty, or rather we are not given one, Then we End

**DocAElstein** · 01-09-2019, 09:54 PM

Post to support this Thread:
http://www.excelfox.com/forum/showth...0888#post10888
_1) This part of Rick’s solution
Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))

I have seen something similar to this before, but it is lost to mankind hidden down in the comment section of a Blog site, Allen Wyatt’s I think…… so its nice that something like this has seen the light of day here…

Originally Posted by Rick Rothstein

If I am not mistaken, this non-looping macro should also work...

Code:

Sub ThisShouldWork()
 Dim LastRow As Long
 LastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))
 Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
End Sub

To help simplify the explanation, lets take it that we know our range , ( http://www.excelfox.com/forum/showth...-row#post10870 ) so we have LastRow = 40
Two arbitrarily chosen characters, @ and # , are being used to enter into the main formula the LastRow or LastRow +1
Pseudo like we are doing this sort of thing
Replace( “A#” , “#” , “40” ) in order to end up with like “A40”
By inspection of the main formula, and with a bit of eye straining you can probably see where you replace those @ and # with 40 and 41
Just to be sure , running this will get you a nice copy able version of the main formula in the immediate window , ( after running you Hit Ctrl+g from the VB Editor to get the immediate window up):

Code:

Sub ThisShouldWork()
Dim LastRow As Long, strEval As String
 Let LastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Let strEval = Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow)
 'Range("B1:B" & LastRow).FormulaArray = "=" & strEval
 Debug.Print strEval  'IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,""))

That did work.JPG : https://imgur.com/01sQ91X

_._______________________-
Before moving on a useful note: It is always useful when developing these formulas to view the string in the Immediate window: That can help with tricky syntaxes : The formula seen on the Immediate window must look like a formula in the same syntax as you would manually type it into a cell. So you can see immediately if you get something wrong , such as an error in the finally seen quotes.
_.__________________________
So we have our final formula:
IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A41," ",""),",","")),IF(LEFT(A1:A40,4)="2018",TRIM(A1:A40&" "&A2:A41),""),IF(LEFT(A1:A40,4)="2018",A1:A40,""))
The way these formulas appear to work within the Evaluate(“ “) appears to be tapping into an along the columns , down a row, then along the columns… type updating raster to update a worksheet. The available output then seems to be that which encompasses the deepest and widest ranges. It is a ,little bit more complicated than that ( http://www.excelfox.com/forum/showth...on-and-VLookUp ) , but for our formula we have nice regular equally sized ranges so we are expecting an output of 1 “wide” and 40 “deep”. So for analysis purposes, we can reduce the formula to 40 similar ones.

Lets take the example of the formula for the 13th “down” output ..
IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13&" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))
Clearly we need to look at this data to see what that formula will do, because this data is used in that formula
_____ Workbook: NormanOrrinRickFilter.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	A
13	2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah,
14	10006098, 15392.64

Worksheet: Rick

We have some nested IFs , and I find it is always a good idea to break those down so that we can start doing them as Excel or VBA would do them, that is to say from the middle working outwards. I tend to do this in a text editor with a horizontal scroll bar, or in the VB Editor window
Formula in VB Editor as comment.JPG : https://imgur.com/3cjyqSR

So this is what we have, broken down into the constituent IF sections.
( It may be better to copy this and view in your VB Editor in a wide window. I am working from the bottom , upwards )

Code:

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) 
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") )
' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))

Examining the first line , I can evaluate the two innermost IFs and reduce the formula to

Code:

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 ) 
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) )

I will now evaluate some of those SUBSTITUTEs
( Excel Substitute, seems to work similarly to VBA Replace )

Code:

' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 ) 
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 )

( I am guessing that 0+ will ensure that a number will not be mistaken as a text )

For the case of the 13th “down” formula the final steps in the evaluation go as follows

Code:

' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
' TRIM(A13" "&A14)

' IF( True , TRIM(A13" "&A14) , A13 )

Here are all the steps together again

Code:

' 2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
' TRIM(A13" "&A14)

' IF( True , TRIM(A13" "&A14) , A13 ) 


' IF( ISNUMBER(0+1000609815392.64), TRIM(A13" "&A14) , A13 ) 
' IF( ISNUMBER(0+SUBSTITUTE(10006098,15392.64),",","")), TRIM(A13" "&A14) , A13 ) 

' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), TRIM(A13" "&A14) , A13 ) 
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) 


' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")), IF(LEFT(A13,4)="2018" , TRIM(A13" "&A14) , "") , IF( LEFT(A13,4)="2018" , A13 ,"" ) ) 
' IF( ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),"") , IF(LEFT(A13,4)="2018",A13,"") )
' IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A14," ",""),",","")),IF(LEFT(A13,4)="2018",TRIM(A13" "&A14),""),IF(LEFT(A13,4)="2018",A13,""))

The final result will appear in the 13th down position of the 40 “deep” array final results for the entire formula evaluation.
If you can view that last summary on a wide window, it should be able to see how the differing results for the other 39 results are achieved from the formula
Just to make clear once again what seems to go on in these sort of Evaluate formulas, in the next post is a table showing the actual Evaluateions done by VBA

_._____

_2 The final part of Rick’s solution is
Range("A1:A" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
This uses the VBA SpecialCells Method to get at the cells with nothing in them. Those are then deleted
Explanation:
VBA SpecialCells Method ( https://www.mrexcel.com/forum/excel-...onditions.html , https://docs.microsoft.com/en-us/off...e.specialcells ) returns you a range object ( that range object must not be contiguous ( connected ) cells ) consisting of those cells meeting a specific characteristic. We can choose from a number of characteristics. Here we choose xlBlanks , which refers to the characteristic of the cell being empty. So, if we applied that .SpecialCells(xlBlanks) to this range:.._

_Row\^Col	B
9
10
11	2018, 1, 90515, 10024515, G9, SBlabla (HQ), CHE, BLABLA, blabla, 10012098, 12003.5
12	2018, 1, 90629, 10022334, P3, BLABLA blabla (blablabla), CHE, BLABLA,blabla, 10033609, 13941.72
13	2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
14
15	2018, 1, 90765, 10012123, P4, Ch of Blabla(Blabla of Blabla), CHE, BLA-BLA,Bla Blabla, 10005678, 16231.7

_ … then the returned range from that would be Range(“B9:B10,B14”).
If we then apply .Delete to that range then those cells are removed. If you remove a cell via .Delete then initially there is a real hole, like a “black hole” that can’t really exist in a spreadsheet. So Excel might explode or implode, or you would be sucked into that hole , never to return!!! To prevent that happening, Excel shifts all cells to close that hole, ( and adds a new virgin cell at the bottom or right side to fill the indent there caused by the shift. The default Delete option for the direction of that shift is in our case upwards. Hence after applying the .Delete after applying .SpecialCells(xlBlanks) to the above range, ( pseudo like doing something this Range(“B9:B10,B14”).Delete(Shift:=xlUp) ) we will be left with

_Row\^Col	B
9	2018, 1, 90515, 10024515, G9, SBlabla (HQ), CHE, BLABLA, blabla, 10012098, 12003.5
10	2018, 1, 90629, 10022334, P3, BLABLA blabla (blablabla), CHE, BLABLA,blabla, 10033609, 13941.72
11	2018, 1, 90709, 10020009, P4, Blabla og Blalala (NY), CHE, Blabla,Bla-ah, 10006098, 15392.64
12	2018, 1, 90765, 10012123, P4, Ch of Blabla(Blabla of Blabla), CHE, BLA-BLA,Bla Blabla, 10005678, 16231.7
13
14

What has happened there is the following: Those empty cells ( which were yellow ) have been removed. Other cells have been shifted up to fill up the “holes” created by the removal
( Rick’s code line actually deletes the EntireRow of that row on which the empty cells are found )

_.______________________________________________

Just to make clear once again what seems to go on in these sort of Evaluate formulas, in the next post is a table showing the actual Evaluateions done by VBA