Appendix Thread. 3 *

[DocAElstein]

Test



17-121-114-118.applebot.apple.com

header1	header2	A Header	Last Column Header
0	SubItem	SubItem	SubItem	SubItem	<-- This is a ListView Item. It has an Item number of 0 and an Item idenitfier/name of 345
1	SubItem	SubItem	SubItem	SubItem	<-- This is a ListView Item. It has an Item number of 1 and an Item idenitfier/name of 232
2	SubItem	SubItem	SubItem	SubItem	<-- This is a ListView Item. It has an Item number of 2 and an Item idenitfier/name of 36

[size]

header1	header2	A Header	Last Column Header
0	SubItem	SubItem	SubItem	<-- This brown thing is a ListView Item. It has an Item number of 0 and an Item idenitfier/name of 345
1	SubItem	SubItem	SubItem	<-- This blue thing is a ListView Item. It has an Item number of 1 and an Item idenitfier/name of 232
2	SubItem	SubItem	SubItem	<-- This purple thing is a ListView Item. It has an Item number of 2 and an Item idenitfier/name of 36

header1	header2	A Header	Last Header	<-- This bit with the created “column” is part of the main ListView object
0\ 345	SubItem	SubItem	SubItem	<-- This brown thing is a ListViewItem object. It has an Item number of 0, and an Item identifier/name of 345
1\ 232	SubItem	SubItem	SubItem	<-- This blue thing is a ListViewItem object. It has an Item number of 1, and an Item identifier/name of 232
2\ 36	SubItem	SubItem	SubItem	<-- This purple thing is a ListViewItem object. It has an Item number of 2 and an Item identifier/name of 36

__
In the above schematic we are showing 4 objects. The last three belong to the first one, ( after they have been ned to it ).
The values in the first column somehow belong to the main ListView object.
SubItems are Added to the ListViewItems

[DocAElstein]

In support of this Thread https://eileenslounge.com/viewtopic.php?f=30&t=38110
https://eileenslounge.com/viewtopic....294721#p294721



Vertical to Horizontal,
This to this

---

Part 1 The main data Vertical to Horizontal
An idea I have is to build up the single string that we know can be put into the Windows Clipboard, and then pasted out into Excel. ( http://www.eileenslounge.com/viewtop...242941#p242941 )
I basically build that up with some Do While Loopy stuff

The Full Story
The usual worksheets defining and data getting information stuff.
( We capture one extra empty row, because, past experience with these sort of Do While Loopy stuff has shown that it can help simplify some conditional comparison things and/ or help prevent arrays doing out of bounds by one row.


Rem 1
The purpose of this is to get that maximum Amounts or Notes count, ( the biggest group ) ( which is 4 in the given example )
But its worth looking at how that works since the basic Do While Loop is then used in the next main ( Rem 2 ) section.
The #### Main Outer Loop keeps us going through all data rows
Within that the ' ---- Inner Loop that takes us through a group
This loop adds the things in the group, and after each loop is finished we check If the count was the biggest group so far.

Rem 2
This is the main meat of the solution.
First, exactly as before we have a #### Main Outer Loop keeps us going through all data rows

Within that Main Outer Loop we now have 2 inner loops.
'2a
The '2a The first inner loop one does something similar to before. It loops for a group. This time within it we build up two strings that we need for a line in the output.
As example, for the first group we are basically trying to build up these two strings, ( Just before we start that loop, we tack onto the string at the start the group name, which is A in the first group example.
This is what we would see, for example in the immediate window, for querying the string content after, in this example, the the loops for that inner loop

 ?  strClipL
A   vbTab  10 vbTab     20 vbTab     30  

?    strClipR
  vbTab    N1  vbTab  N2  vbTab  N3

( For the sake of clarity I use a vbTab to indicate the “invisible” vbTab characters, which is actually on those strings )
'2b
The purpose of '2b the second inner loop is to ,( if necessary ), give us effectively extra empty cells, ( achieved by adding a vbTab of the strings.
Using the same example, we would see that the loop is needed to be done once, and at the end of that single loop, our strings are modifies such:

 ?  strClipL
A   vbTab  10 vbTab     20 vbTab     30   vbTab  

?    strClipR
  vbTab    N1  vbTab  N2  vbTab  N3  vbTab 

'2c
At this point we combine the two strings and add a line separator so that this row data can be added onto by the next row data
So as to be sure what I have and demonstrate it more clearly, I added a line in testing which calls a function of mine , ( https://excelfox.com/forum/showthrea...ll=1#post15522 ) , which checks that line screen,
Here is the result

"A" & vbTab & "10" & vbTab & "20" & vbTab & "30" & vbTab & vbTab & "N1" & vbTab & "N2" & vbTab & "N3" & vbTab & vbTab & "GroupA" & vbCr & vbLf

That looks about correct.

Doing a few other tests, suggest to me that I have the final result that I need:

 ? strclip
A   10  20  30      N1  N2  N3      GroupA
B   40  50  60  70  N4  N5  N6  N7  GroupB
C   80              N8              GroupC
D   90  100         N9  N10         GroupD


"A" & vbTab & "10" & vbTab & "20" & vbTab & "30" & vbTab & vbTab & "N1" & vbTab & "N2" & vbTab & "N3" & vbTab & vbTab & "GroupA" & vbCr & vbLf & "B" & vbTab & "40" & vbTab & "50" & vbTab & "60" & vbTab & "70" & vbTab & "N4" & vbTab & "N5" & vbTab & "N6" & vbTab & "N7" & vbTab & "GroupB" & vbCr & vbLf & "C" & vbTab & "80" & vbTab & vbTab & vbTab & vbTab & "N8" & vbTab & vbTab & vbTab & vbTab & "GroupC" & vbCr & vbLf & "D" & vbTab & "90" & vbTab & "100" & vbTab & vbTab & vbTab & "N9" & vbTab & "N10" & vbTab & vbTab & vbTab & "GroupD" & vbCr & vbLf

---

' Ref
' http://www.eileenslounge.com/viewtop...=31395#p242941
' http://www.eileenslounge.com/viewtop...=31489#p243731
' http://www.eileenslounge.com/viewtop...=31938#p247681
' http://www.eileenslounge.com/viewtop...art=20#p246887
https://eileenslounge.com/viewtopic....294721#p294721
' http://web.archive.org/web/202001241...ms-dataobject/
' https://stackoverflow.com/questions/...60767#54960767
' https://stackoverflow.com/questions/...12342#59812342
‘ http://web.archive.org/web/202001241...ms-dataobject/


‘ https://www.myonlinetraininghub.com/excel-clipboard https://support.microsoft.com/en-us/...&fromar=1#bm2b
‘ https://www.thespreadsheetguru.com/b...nal-macro-file
‘ https://excelribbon.tips.net/T009810...Clipboard.html
‘ https://www.excelforum.com/excel-pro...t-working.html
‘ https://www.thespreadsheetguru.com/b...-the-clipboard
https://excelribbon.tips.net/T010691...Clipboard.html
https://excel.tips.net/T003111_Cant_...Workbooks.html

' VBA to clear the Office Clipboard http://www.eileenslounge.com/viewtop...634c64#p246838

[DocAElstein]

Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529

'  https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16529&viewfull=1#post16529
'  http://www.eileenslounge.com/viewtopic.php?f=30&t=38110&p=294692#p294692
Sub Stantial()
Rem 0 data
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim RngPlus1 As Range
 Set RngPlus1 = Ws1.Cells.Item(1).CurrentRegion.Resize(Ws1.Cells.Item(1).CurrentRegion.Rows.Count + 1, Ws1.Cells.Item(1).CurrentRegion.Columns.Count)
Dim vArr() As Variant: Let vArr() = RngPlus1.Value2
Rem 1 determine the biggest group ( that maximum Amounts or Notes count )
Dim Cnt As Long, Cnt2 As Long, Mx As Long: Let Mx = 1: Let Cnt = 1
    Do  '            ############################# Main Outer Loop keeps us going through all data rows
        Do  '                           -----------------  Inner Loop that takes us through a group
         Let Cnt = Cnt + 1 ' Cnt is the main data row number
         Let Cnt2 = Cnt2 + 1
        Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1) ' ----  Inner Loop that takes us through a group
        If Cnt2 > Mx Then Let Mx = Cnt2
     Let Cnt2 = 0
    Loop While Cnt < UBound(vArr(), 1) - 1 '  #### Main Outer Loop keeps us going through all data rows

Rem 2 '            ############################# Main Outer Loop keeps us going through all data rows
 Let Cnt = 1
    Do
    Dim HrCnt As Long: Let HrCnt = 1
    Dim strClipR As String, strClipL As String: Let strClipL = strClipL & vArr(Cnt + 1, 1)
        Do                                         '2a The first inner loop
         Let Cnt = Cnt + 1
         Let HrCnt = HrCnt + 1
         Let strClipL = strClipL & vbTab & vArr(Cnt, 2)
         Let strClipR = strClipR & vbTab & vArr(Cnt, 3)
        Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1) '   The first inner loop
        Do While HrCnt < Mx + 1                    '2b the second inner loop
         Let strClipL = strClipL & vbTab
         Let strClipR = strClipR & vbTab
         Let HrCnt = HrCnt + 1
        Loop                                       '   the second inner loop
    '2c Finishing off the strings, and final string for an output line, after the inner loops
     Let strClipR = strClipR & vbTab & vArr(Cnt, 4) ' add the group name
    Dim strClip As String: Let strClip = strClip & strClipL & strClipR & vbCr & vbLf  ' join the strings and add a line seperator to the output row string
    'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strClip)
    Let strClipL = "": strClipR = ""
    Loop While Cnt < UBound(vArr(), 1) - 1 '  #### Main Outer Loop keeps us going through all data rows
 'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strClip)
'2d paste  strClip  out via the windows Clipboard
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")   '     http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
 objDataObject.SetText Text:=strClip
 objDataObject.PutInClipboard
 Ws1.Paste Destination:=Ws1.Range("G2")

End Sub

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9iHOYYpaA bC
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7G-bVm8_-
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7EqbG23kg
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg.9h4sd6Vs4qE9h7KvJXmK 8o
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg.9h6VhNCM-DZ9h7E1gwg4Aq
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79hNGvJ bu
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79YAfa2 4T
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h79M1SYH 1E
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78SxhXT nR
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

[DocAElstein]

Spare post for later

Row\Col	A	B	C	D
1	Numbers	ID	Date
2	12345	22	01/03/2022
3	12345	22	01/03/2022
4	12345	22	01/03/2022
5	12345	22	01/03/2022
6	12345	22	01/05/2022
7	12345	22	01/05/2022
8	12345	22	01/06/2022
9	12345	22	01/06/2022
10	12345	22	04/02/2022
11	12345	22	04/02/2022
12	12345	22	04/02/2022
13	12345	22	04/03/2022
14	12345	22	04/03/2022
15	12345	22	04/04/2022
16	23456	22	01/03/2022
17	23456	22	01/03/2022
18	23456	22	01/03/2022
19	23456	22	01/04/2022
20	23456	22	01/04/2022
21

Worksheet: Data

And this is your results.

Row\Col	A	B	C	D	E	F	G
1	Number	ID	Start Date	End Date	Days	Working Days
2	12345	22	01/03/2022	04/04/2022	92	64	Incorrect
3	23456	22	01/03/2022	01/04/2022	2	1
4
5
6
7	12345	22	01/03/2022	01/06/2022	4	3	Correct
8	12345	22	04/02/2022	04/04/2022	3	0

Worksheet: Result

It is impossible to understand why you have more than one result for 12345

[DocAElstein]

Following on from posts,
https://excelfox.com/forum/showthrea...ll=1#post16530 https://excelfox.com/forum/showthrea...ll=1#post16529
http://www.eileenslounge.com/viewtop...294692#p294692
,

The header row,
Group Amount1 Amount2 Amount3 Amount4 Notes1 Notes2 Notes3 Notes4 Name
, we could make partially dynamic, as is needed, since we don’t know the maximum number of amounts ( = maximum number of Notes ) , before seeing the data.

We do have the information needed, since Mx contains, in our current example, the required value of 4

Evaluate Range techniques are a convenient way to get these sort of things.

We start by considering spreadsheet formulas such as this,
={"Amount" & COLUMN(A1:D1)}
, which returns us an array, which applied across a range , would give us like
Amount1 Amount2 Amount3 Amount4

Taking that general idea and a few other steps we can finally get at our heading like in this demo coding

' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16532&viewfull=1#post16532
Sub MakeHeadings()
Dim Mx As Long: Let Mx = 4
Dim Amounts() As Variant
 Let Amounts() = Evaluate("=""Amount"" & COLUMN(A1:D1)")
 Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:D)")
 Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:" & "D" & ")")
' We need to get   D  from what we know,  Mx
Dim vTemp As Variant
 vTemp = Cells(1, 4).Address
 vTemp = Split(vTemp, "$", 3, vbBinaryCompare)
 vTemp = vTemp(1)
' Or
 vTemp = Split(Cells(1, 4).Address, "$", 3, vbBinaryCompare)(1)
' Or
 vTemp = Split(Cells(1, 4).Address, "$")(1)
 vTemp = Split(Cells(1, Mx).Address, "$")(1)

Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:" & vTemp & ")")
Let Amounts() = Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")")
'
' We want this array as a string with   vbTabs seperating the array elements
Dim strAmounts As String
 Let strAmounts = Join(Amounts(), vbTab)
 Let strAmounts = Join(Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab)

' similarly for the  notes
Dim strNotes As String
 Let strNotes = Join(Evaluate("=""Note"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab)

' To get our final heading string,
Dim strHd As String
 Let strHd = "Group" & vbTab & Join(Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & Join(Evaluate("=""Note"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & "Notes"

Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")   '     http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
 objDataObject.SetText Text:=strHd
 objDataObject.PutInClipboard
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
 Ws1.Paste Destination:=Ws1.Range("G1")

End Sub

In the next post , https://excelfox.com/forum/showthrea...ll=1#post16533 , is that integrated into the main coding in Rem 3

[DocAElstein]

Coding for these posts
https://excelfox.com/forum/showthrea...ll=1#post16532

Sub Stantially()
Rem 0 data
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim RngPlus1 As Range
 Set RngPlus1 = Ws1.Cells.Item(1).CurrentRegion.Resize(Ws1.Cells.Item(1).CurrentRegion.Rows.Count + 1, Ws1.Cells.Item(1).CurrentRegion.Columns.Count)
Dim vArr() As Variant: Let vArr() = RngPlus1.Value2
Rem 1 determine the biggest group ( that maximum Amounts or Notes count )
Dim Cnt As Long, Cnt2 As Long, Mx As Long: Let Mx = 1: Let Cnt = 1
    Do  '            ############################# Main Outer Loop keeps us going through all data rows
        Do  '                           -----------------  Inner Loop that takes us through a group
         Let Cnt = Cnt + 1 ' Cnt is the main data row number
         Let Cnt2 = Cnt2 + 1
        Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1) ' ----  Inner Loop that takes us through a group
        If Cnt2 > Mx Then Let Mx = Cnt2
     Let Cnt2 = 0
    Loop While Cnt < UBound(vArr(), 1) - 1 '  #### Main Outer Loop keeps us going through all data rows

Rem 2 '            ############################# Main Outer Loop keeps us going through all data rows
 Let Cnt = 1
    Do
    Dim HrCnt As Long: Let HrCnt = 1
    Dim strClipR As String, strClipL As String: Let strClipL = strClipL & vArr(Cnt + 1, 1)
        Do                                         '2a The first inner loop
         Let Cnt = Cnt + 1
         Let HrCnt = HrCnt + 1
         Let strClipL = strClipL & vbTab & vArr(Cnt, 2)
         Let strClipR = strClipR & vbTab & vArr(Cnt, 3)
        Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1) '   The first inner loop
        Do While HrCnt < Mx + 1                    '2b the second inner loop
         Let strClipL = strClipL & vbTab
         Let strClipR = strClipR & vbTab
         Let HrCnt = HrCnt + 1
        Loop                                       '   the second inner loop
    '2c Finishing off the strings, and final string for an output line, after the inner loops
     Let strClipR = strClipR & vbTab & vArr(Cnt, 4) ' add the group name
    Dim strClip As String: Let strClip = strClip & strClipL & strClipR & vbCr & vbLf  ' join the strings and add a line seperator to the output row string
    'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strClip)
    Let strClipL = "": strClipR = ""
    Loop While Cnt < UBound(vArr(), 1) - 1 '  #### Main Outer Loop keeps us going through all data rows
 'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strClip)
'2d paste  strClip  out via the windows Clipboard
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")   '     http://web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
 objDataObject.SetText Text:=strClip
 objDataObject.PutInClipboard
 Ws1.Paste Destination:=Ws1.Range("G2")

Rem 3 headers
Dim strHd As String
 Let strHd = "Group" & vbTab & Join(Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & Join(Evaluate("=""Note"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & "Name"
 objDataObject.SetText Text:=strHd
 objDataObject.PutInClipboard
 Ws1.Paste Destination:=Ws1.Range("G1")

End Sub

[DocAElstein]

Some extra notes for this main forum post:
http://www.eileenslounge.com/viewtopic.php?f=27&t=38331

This is a sample input,

_____ Workbook: Split- Copy.xlsm ( Using Excel 2007 32 bit )

Row\Col	A	B
2	1,2,3,4	t,y,u,m

Worksheet: Sheet2Original

This is what I want out

_____ Workbook: Split- Copy.xlsm ( Using Excel 2007 32 bit )

Row\Col	A	B
2	1	t
3	2	y
4	3	u
5	4	m

Worksheet: Sheet2


I want to do this sort of thing,

__ arrOut()= App.Index(arrIn(), Rws(), Clms())

The arrIn() in this case will be all the input data. Conveniently, we can join the two cell values with a comma then split all that by comma to get a single array, {1 2 3 4 t y u m }
Then we need the Rws() like this
1 1
1 1
1 1
1 1
and the Clms() like this
1 5
2 6
3 7
4 8

'  https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16639&viewfull=1#post16639
Sub SplitData4()
Dim Ws2 As Worksheet: Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2")
Dim strDta As String: Let strDta = Ws2.Range("A2").Value & "," & Ws2.Range("B2").Value
Dim arrIn() As String
 Let arrIn() = Split(strDta, ",", -1, vbBinaryCompare)
' Or
 arrIn() = Split(Range("A2").Value & "," & Range("B2").Value, ",")
Dim Rws() As Variant
 Let Rws() = Evaluate("=Row(1:4)/Row(1:4)*Column(A:B)/Column(A:B)")
 Let Rws() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")/Row(1:" & (UBound(arrIn()) + 1) / 2 & ")*Column(A:B)/Column(A:B)")
Dim Clms() As Variant
 Let Clms() = Evaluate("=Row(1:4)+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")")
 Let Clms() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")")

Dim arrOut() As Variant
 Let arrOut() = Application.Index(arrIn(), Rws(), Clms())

 Let Ws2.Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = arrOut()

' Or
' Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = arrOut()
' Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = Application.Index(arrIn(), Rws(), Clms())
' Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = Application.Index(arrIn(), Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")/Row(1:" & (UBound(arrIn()) + 1) / 2 & ")*Column(A:B)/Column(A:B)"), Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")"))

 Range("A2").Resize((UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2, 2).Value = Application.Index(Split(Range("A2").Value & "," & Range("B2").Value, ","), Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")/Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")*Column(A:B)/Column(A:B)"), Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")"))
 
End Sub

Sub StantiallyBeautiful() '  http://www.eileenslounge.com/viewtopic.php?f=27&t=38331
 Range("A2").Resize((UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2, 2).Value = Application.Index(Split(Range("A2").Value & "," & Range("B2").Value, ","), Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")/Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")*Column(A:B)/Column(A:B)"), Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")"))
End Sub

---

In actual fact, we can simplify things a bit , since Intersexual interception theory tells us that if Excel is looking for the indicies of this form
A b
C d
E f
G h
, but we only give it
1
, then it will see this instead
1 1
1 1
1 1
1 1

So that means we can replace Rws() with just 1
So that all simplifies it a bit…

Sub SplitData4b()
Dim Ws2 As Worksheet: Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2")
Dim strDta As String: Let strDta = Ws2.Range("A2").Value & "," & Ws2.Range("B2").Value
Dim arrIn() As String
 Let arrIn() = Split(strDta, ",", -1, vbBinaryCompare)
' Or
 arrIn() = Split(Range("A2").Value & "," & Range("B2").Value, ",")
'Dim Rws() As Variant
' Let Rws() = Evaluate("=Row(1:4)/Row(1:4)*Column(A:B)/Column(A:B)")
' Let Rws() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")/Row(1:" & (UBound(arrIn()) + 1) / 2 & ")*Column(A:B)/Column(A:B)")
Dim Clms() As Variant
 Let Clms() = Evaluate("=Row(1:4)+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")")
 Let Clms() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")")

Dim arrOut() As Variant
' Let arrOut() = Application.Index(arrIn(), Rws(), Clms())
 Let arrOut() = Application.Index(arrIn(), 1, Clms())
 Let Ws2.Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = arrOut()

' Or
' Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = arrOut()
' Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = Application.Index(arrIn(), 1, Clms())
' Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = Application.Index(arrIn(), 1, Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")"))

 Range("A2").Resize((UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2, 2).Value = Application.Index(Split(Range("A2").Value & "," & Range("B2").Value, ","), 1, Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")"))
End Sub

Sub StantiallyBeautifulb() '  http://www.eileenslounge.com/viewtopic.php?f=27&t=38331
 Range("A2").Resize((UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2, 2).Value = Application.Index(Split(Range("A2").Value & "," & Range("B2").Value, ","), 1, Evaluate("=Row(1:" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(Split(Range("A2").Value & "," & Range("B2").Value, ",")) + 1) / 2 & ")"))
End Sub

[DocAElstein]

some more notes on it....


later.....

[DocAElstein]

This is post https://excelfox.com/forum/showthrea...ll=1#post16643
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16643&viewfull=1#post16643
https://excelfox.com/forum/showthrea...ge54#post16643
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page54#post16643

---

Some more notes related to these posts
http://www.eileenslounge.com/viewtop...296482#p296482

---

Making it more flexible / dynamic, most for academic interest and aesthetic Pleasure

The code is flexible already in terms of the number of elements in each cell, ( but note The macro assumes the cells all have the same number of elements - like __ 1,2,3,4 __ t,y,u,m __ 5,6,7,8 __ a,b,c,d )
This post extends the flexibility to a dynamic number of cells used. ( While I was writing this, the OP asked for a mod to increase the used cells from 2 to 4, so a flexible solution is , as often, worthwhile )

We almost certainly need to know how many cells we have, and the usual way is done to get that,
__ Lc = Ws1.Cells(2, Ws1.Columns.Count).End(xlToLeft).Column

Join an array of the cells
The key to the new flexible solution is to Join the elements of an array with a comma, where the elements are the cell values, which themselves are separated already with a comma. (So then as previously, we then finally have a single string of comma separated values, which we , as previously split by a comma, to give us our single array of all data values.
Initially we can get an array of cell values from applying the .Value property to our multi cell range.
Something of this sort of form, for example, for if we had 4 cells in the second row,
_________arrCels2D1Row() = Ws1.Range("A2:D2").Value2
A small snag here is that the array returned by the .Value property, is a 1 row, 2 Dimensional array, ( a pseudo “horizontal” , “single width” array) but the VBA strings Join function only accepts a 1 dimensional array. However, it’s a strange characteristic of VBA that many things if they are asked to return something in the orientation of pseudo “horizontal” , “single width” , then they return a 1 Dimensional array: It seems that somehow the internal workings often relate a row orientation to a single dimensional array. ( This is convenient to think about, as is the idea of pseudo “horizontal” , “single width” , since in the case of a 1 dimensional array we often write it in a line like {1, 2, 3, 6, "z"} , but we should remember that strictly speaking academically orientation in arrays is subjective. )
As example this seemingly redundant code line takes the first row from our single row 2 Dimensional array: Seemingly useless, but in fact it returns the 1 Dimensional array of cell values, as we require, -
___ arrCels1D() = Application.Index(arrCels2D1Row(), 1, 0)
___ ___ - Effectively that converts a 2 Dimensional 1 row array into a 1 Dimensional array, and why VBA has that sort of strange characteristic thing is not clearly known


After this, we simply modify the previous solutions to replace some hard coded values with the dynamic Lc: For example we see the number 2 used frequently, when we originally had 2 cells, and this will likely need to be replaced by Lc, and correspondingly we used B in places where this will likely need to be replaced by the column letter corresponding to column Lc


Unfortunately, the final single code line does not quite fit on one line, but it is one code line, but needs to be split to get it in the VB Editor

Sub PrettydammBeautiful()
 Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = _
 Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))

End Sub

Here the full story: see next post

[DocAElstein]

Here is the full workings for the last macro from the last post

Sub SplitDataFlexibly() '
Rem 1 worksheets data info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim Lc As Long: Let Lc = Ws1.Cells(2, Ws1.Columns.Count).End(xlToLeft).Column: Lc = Cells(2, Columns.Count).End(xlToLeft).Column
Rem 2 create a 1 Dimensional array of all data
Dim LCL As String: Let LCL = Split(Cells(1, Lc).Address, "$", 3, vbBinaryCompare)(1): LCL = Split(Cells(1, Lc).Address, "$")(1) ' what we are doing is splitting like  $D$1  by the  $  and then taking the second element,  in the example that will be  D
Dim arrCels2D1Row() As Variant: Let arrCels2D1Row() = Ws1.Range("A2:" & LCL & "2").Value2
Dim arrCels1D() As Variant: Let arrCels1D() = Application.Index(arrCels2D1Row(), 1, 0)
Dim strDta As String: Let strDta = Join(arrCels1D(), ",")                                        'Ws2.Range("A2").Value & "," & Ws2.Range("B2").Value
Rem 3 Making previous solution dynamic, - requires changing  B  with  " & LCL & "   and some hard coded occurasnces  of  2  with   Lc
Dim arrIn() As String
 Let arrIn() = Split(strDta, ",", -1, vbBinaryCompare)
' Or
 arrIn() = Split(Join(arrCels1D(), ","), ",")
Dim Clms() As Variant
 ' the next lines, used in previous example. is for the case of two cells, so we need to change some hard coded stuff to make the solution dynamic. ' Let Clms() = Evaluate("=Row(1:4)+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")")
 ' Let Clms() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / 2 & ")+((Column(A:B)-1)*" & (UBound(arrIn()) + 1) / 2 & ")")
  Let Clms() = Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(arrIn()) + 1) / Lc & ")")
Dim arrOut() As Variant
 Let arrOut() = Application.Index(arrIn(), 1, Clms())
' Let Ws2.Range("A2").Resize((UBound(arrIn()) + 1) / 2, 2).Value = arrOut() ' This was the case for 2 cells
 Let Ws1.Range("A2").Resize((UBound(arrIn()) + 1) / Lc, Lc).Value = arrOut()
' Or
' Range("A2").Resize((UBound(arrIn()) + 1) / Lc, Lc).Value = arrOut()
' Range("A2").Resize((UBound(arrIn()) + 1) / Lc, Lc).Value = Application.Index(arrIn(), 1, Clms())
' Range("A2").Resize((UBound(arrIn()) + 1) / Lc, Lc).Value = Application.Index(arrIn(), 1, Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(arrIn()) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(arrCels1D(), ","), ",")) + 1) / Lc, Lc).Value = Application.Index(Split(Join(arrCels1D(), ","), ","), 1, Evaluate("=Row(1:" & (UBound(arrIn()) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(arrIn()) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(arrCels1D(), ","), ",")) + 1) / Lc, Lc).Value = Application.Index(Split(Join(arrCels1D(), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(arrCels1D(), ","), ",")) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(Split(Join(arrCels1D(), ","), ",")) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Lc, Lc).Value = Application.Index(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Ws1.Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")) + 1) / Lc, Lc).Value = Application.Index(Split(Join(Application.Index(Ws1.Range("A2:" & LCL & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Ws1.Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")) + 1) / Lc & ")+((Column(A:" & LCL & ")-1)*" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Ws1.Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Lc, Lc).Value = Application.Index(Split(Join(Application.Index(Ws1.Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Ws1.Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")) + 1) / Lc & ")+((Column(A:" & Split(Cells(1, Lc).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Lc, Lc).Value = Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")) + 1) / Lc & ")+((Column(A:" & Split(Cells(1, Lc).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Lc & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(arrCels2D1Row(), 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(Range("A2:" & LCL & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))
' Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Lc).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))
 Range("A2").Resize((UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column, Cells(2, Columns.Count).End(xlToLeft).Column).Value = _
 Application.Index(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ","), 1, Evaluate("=Row(1:" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")+((Column(A:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & ")-1)*" & (UBound(Split(Join(Application.Index(Range("A2:" & Split(Cells(1, Cells(2, Columns.Count).End(xlToLeft).Column).Address, "$")(1) & "2").Value2, 1, 0), ","), ",")) + 1) / Cells(2, Columns.Count).End(xlToLeft).Column & ")"))

End Sub