-
In support of this Thread https://eileenslounge.com/viewtopic.php?f=30&t=38110
https://eileenslounge.com/viewtopic....294721#p294721
Vertical to Horizontal,
This https://i.postimg.cc/14t4nPfD/This-Virtical.jpg to this https://i.postimg.cc/ygfdQprJ/That-Horizintal.jpg
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
Code:
? 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:
Code:
? 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
Code:
"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: https://i.postimg.cc/xcbJDZgM/StrClip.jpg
Code:
? 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
-
Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529
Code:
' 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
-
Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529
Code:
' 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
-
Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529
Code:
' 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
-
Coding so far , for last post, https://excelfox.com/forum/showthrea...ll=1#post16529
Code:
' 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
