Office Activating

**DocAElstein** · 04-26-2022, 12:19 PM

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

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:

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

**DocAElstein** · 04-26-2022, 06:16 PM

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

**DocAElstein** · 04-26-2022, 06:16 PM

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

**DocAElstein** · 04-26-2022, 06:16 PM

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

**DocAElstein** · 04-26-2022, 06:16 PM

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