Tests Copying, Pasting, API Cliipboard issues. and Rough notes on Advanced API stuff

White Spam URL WhiteSpamUrl WhiteSpamUrl()

Code:

---

Sub WhiteSpamUrl()  '  White Spam URL  WhiteSpamUrl WhiteSpamUrl()  https://www.excelfox.com/forum/showthread.php/2348-String-text-in-Word-html-Passing-info-between-Word-and-Excel?p=21222&viewfull=1#post21222    https://www.excelfox.com/forum/showthread.php/2824-Tests-Copying-pasting-Cliipboard-issues?p=18376&viewfull=1#post18376
Dim ClipTxt As String: Let ClipTxt = "[url=https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA] [COLOR=white] htt[COLOR=white]p[/COLOR]s:/[COLOR=white]/w[/COLOR]ww.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA [/color] [/url]" & vbCr & vbLf
Dim SelText As String
 Let SelText = Selection.Text
Dim RwTxt() As String
 Let RwTxt() = Split(SelText, vbCr, -1, vbBinaryCompare)
Dim RwCnt As Long
    For RwCnt = LBound(RwTxt()) To UBound(RwTxt())
    Dim ClmTxt() As String
    Let ClmTxt() = Split(RwTxt(RwCnt), " ", -1, vbBinaryCompare)
    Dim ClmCnt As Long
        For ClmCnt = LBound(ClmTxt()) To UBound(ClmTxt())
            If InStr(1, Trim(ClmTxt(ClmCnt)), "//www.", vbBinaryCompare) > 0 Then
            Dim URL As String, URL2 As String
            Let URL = Trim(ClmTxt(ClmCnt))
            Let URL2 = Replace(URL, "http", "ht[color=white]tp[/color]", 1, 1, vbBinaryCompare)
            Let URL2 = Replace(URL2, "//www.", "/[color=white]/ww[/color]w.", 1, 1, vbBinaryCompare)
            Let ClipTxt = ClipTxt & "[url=" & URL & "] [color=white] " & URL2 & " [/color] [/url]" & vbCr & vbLf
            Else
            ' no url
            End If
       
        Next ClmCnt
    Next RwCnt
 Let ClipTxt = ClipTxt & "[url=https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA] [COLOR=white] htt[COLOR=white]p[/COLOR]s:/[COLOR=white]/w[/COLOR]ww.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA [/color] [/url]"

'  Put the string in the clipboard
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '  web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
    .SetText ClipTxt
    .PutInClipboard
    End With
End Sub

---

Code:

---

Sub FuckoffvbCrandvbLfinwordtext()  '  https://www.excelfox.com/forum/showt...ll=1#post18377
Dim ClipTxt As String ':                                                                                                                                                Let ClipTxt = " https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA " & vbCr & vbLf
Dim SelText As String
 Let SelText = Selection.Text

 Let ClipTxt = Replace(SelText, vbCr, "", 1, -1)
 Let ClipTxt = Replace(ClipTxt, vbLf, "", 1, -1)
'  Put the string in the clipboard
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '  web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
    .SetText ClipTxt
    .PutInClipboard
    End With
End Sub

---

Code:

---

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

---

In support of this main Forum post:
http://www.eileenslounge.com/viewtop...297074#p297074 http://http://www.eileenslounge.com/viewtop...297074#p297074
First overcomplicated Solution

Hello

Quote:

---

Originally Posted by adeel1 post_id=297073 time=1657888942 user_id=7609

.... in real these values will go to another WBK.
:::
or now just one question, "public" will always declare for userfrom means storing value either within WBK or for Other WBK.

---

Quote:

---

Originally Posted by HansV post_id=297076 time=1657891714 user_id=53

Public means that the variable will be "known" in all code modules of the same workbook, but not in code modules in other open workbooks. .

---

If Public variables are being the things that go in a normal code module, as I think they are, technically, or officially, or words to that effect, then that is the case that they won’t be known in other workbooks.
In other words, for the purposes of what is going on here, it means you will need to be storing them in the same workbook, as Hans said, and how he demonstrated.

However, you can do something that technically is not involving Public variables, but as far as I can tell, to all intents and purposes, is in effect the same thing as if you could have those Public variable in a different workbook.

The short story is:
Instead of putting the two public variables in a standard normal code module, ( in the same workbook) as Hans did, we can put them in any Class object code module in any open workbook. Technically they are not called Public variables. They are , I think, properties of the instantiated Class object, and we can access them, in the usual way that we access properties of an object.

The full story
PurseWayDoughPublicVariables.xls
I have another workbook uploaded, PurseWayDoughPublicVariables.xls . That is just to hold these variables. (I will call them “pseudo” Public variables, just because I feel like it :) ),
I can put them in any Class object code module, but just for fun, I will put C1 in a worksheet code module, and C2 in the ThisWorkbook code module.

So, this is what Hans did, public variables in a standard normal module like
Standard module, Module1

Code:

---

Public C1 As String
Public C2 As String

---

Instead of doing that , I will put those variables in Class object code modules in PurseWayDoughPublicVariables.xls, like this:

Worksheet code module, Sheet1

Code:

---

Public C1 As String
'
'
'
Sub PhilC1(ByVal Wrd As String)
 Let C1 = Wrd
End Sub

---

Workbook code module, ThisWorkbook

Code:

---

Public C2 As String
'
'
'
Sub PhilC2(ByVal Wrd As String)
 Let C2 = Wrd
End Sub

---

*** The reason for those extra macros that fill the variables will be apparent shortly….
_.__________________________________-

Sample for Eli.xlsm
I need to modify now the workbook uploaded by Hans, in 3 main ways:
_(i) I don’t need the two public variables in a standard normal code module anymore
_(ii) I need to modify slightly how I reference the variables

Code:

---

Sub Fi_l()
    'Act_ive
 'Let Range("A2").Resize(10).Value = C1
 Let Range("A2").Resize(10).Value = Workbooks("PurseWayDoughPublicVariables.xls").Worksheets("Sheet1").C1
 'let Range("B2").Resize(10).Value = C2
 Let Range("B2").Resize(10).Value = Workbooks("PurseWayDoughPublicVariables.xls").C2
End Sub

---

_(iii) Filling the variable is slightly more tricky. As far as I know, I can’t easily directly fill them from a macro in Sample for Eli.xlsm. - ***Edit: not true - see next post!! But I can run those extra macros*** that fill the variables, from Sample for Eli.xlsm
So to do that I modify the coding in the UserForm thus, ( for the purposes of this demo, I assume the two workbooks are stored in the same place):

Code:

---

Private Sub CommandButton1_Click()
    Select Case Me.CheckBox1
    Case True
      'C1 = "yes"
      Application.Run Macro:="'" & ThisWorkbook.Path & "\" & "PurseWayDoughPublicVariables.xls'!Sheet1.PhilC1", Arg1:="Yus"
    End Select
    Select Case Me.CheckBox2
    Case True
      'C2 = "yes"
      Application.Run Macro:="'" & ThisWorkbook.Path & "\" & "PurseWayDoughPublicVariables.xls'!ThisWorkbook.PhilC2", Arg1:="Ja"
    End Select
 Unload Me
 Call Sheet2.Fi_l
End Sub

---

_.____

That’s it. So download both files, store them in the same place, and then the coding in Sample for Eli.xlsm should work as before. The only difference is that you are using the “pseudo” public variables in the workbook PurseWayDoughPublicVariables.xls

_.________________________________________________ _____________________


I have not seen this use of “pseudo” public variables much before, so there may be some reason I don’t know about why they should not be used??
But I use them myself sometimes, and so far I have never seen them behave any differently to “proper” public variables

( I would just finally say that I don’t use public variables much myself, pseudo or otherwise, if I can find another way to do what I want. I don’t like public variables myself. For one reason: I find they have an annoying habit of getting emptied sometimes. )



Alan


Ref
https://stackoverflow.com/questions/...ther-workbook#
https://excelfox.com/forum/showthrea...ll=1#post11870
https://stackoverflow.com/questions/...12342#59812342
https://www.mrexcel.com/board/thread.../#post-4629654

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


---

_.________________________________________________ _______________________________




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 https://i.postimg.cc/vxWK4VnG/Amount...ay-Formula.jpg

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

Code:

---

' 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







In support of this main Forum post:
http://www.eileenslounge.com/viewtop...297074#p297074 http://http://www.eileenslounge.com/viewtop...297074#p297074
Second simplified Solution

I think in the first solution I made initially a mistake in trying to set the pseudo public variables, *** and so went off in a tangent using the Application.Run stuff. You don’t need any of that and can forget the two macros that fill the variables as well.

You just need this

Worksheet code module, Sheet1 ( in PurseWayDoughPublicVariables.xls )

Code:

---

Public C1 As String

---

Workbook code module, ThisWorkbook ( in PurseWayDoughPublicVariables.xls )

Code:

---

Public C2 As String

---

And then the other macros are like

Code:

---

Private Sub CommandButton1_Click()
    Select Case Me.CheckBox1
    Case True
      'C1 = "yes"
                                          '  Application.Run Macro:="'" & ThisWorkbook.Path & "\" & "PurseWayDoughPublicVariables.xls'!Sheet1.PhilC1", Arg1:="Yus"
    Let Workbooks("PurseWayDoughPublicVariables.xls").Worksheets("Sheet1").C1 = "Yus"
    End Select
    Select Case Me.CheckBox2
    Case True
      'C2 = "yes"
                                          '  Application.Run Macro:="'" & ThisWorkbook.Path & "\" & "PurseWayDoughPublicVariables.xls'!ThisWorkbook.PhilC2", Arg1:="Ja"
    Let Workbooks("PurseWayDoughPublicVariables.xls").C2 = "Ja"
    End Select
 Unload Me
 Call Sheet2.Fi_l
End Sub


---

Code:

---

Sub Fi_l()
    'Act_ive
 'Let Range("A2").Resize(10).Value = C1
 Let Range("A2").Resize(10).Value = Workbooks("PurseWayDoughPublicVariables.xls").Worksheets("Sheet1").C1
 'let Range("B2").Resize(10).Value = C2
 Let Range("B2").Resize(10).Value = Workbooks("PurseWayDoughPublicVariables.xls").C2
End Sub

---

In support of this main forum post
https://excelfox.com/forum/showthrea...cell-in-sheet2

Code:

---

Sub WhatsInColumnA()
Rem 0 worksheets data info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Rem 1 Put data range in clipboards
 Ws1.UsedRange.Copy
Rem 2 get text data from 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/
Dim StringBack As String
 objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Rem 3 Analyse string back from windows clipboard
 Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(StringBack)    '  https://pastebin.com/raw/eutzzxHv
End Sub

---

Results

Code:

---

"""" & "234" & "." & " " & Chr(42) & ChrW(8230) & "." & "Keywrod1" & ":" & " " & vbLf & "2021" & "-" & "2022" & Chr(42) & Chr(42) & Chr(42) & """" & vbCr & vbLf & vbCr & vbLf & """" & "This also " & vbLf & "text channel" & "." & """" & vbCr & vbLf & """" & "Digital to " & vbLf & "connect communication" & "." & " " & """" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & """" & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." & """" & vbCr & vbLf & vbCr & vbLf & "Keywrod1" & ":" & " " & vbCr & vbLf & "Keyword2" & ":" & "  QWERTY" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & """" & "2344" & "." & " " & ChrW(8230) & "." & "Keywrod1" & ":" & " " & Chr(42) & Chr(42) & Chr(42) & " 2020" & "-" & "2021" & vbLf & "digital information" & vbLf & "digital information" & """" & vbCr & vbLf & vbCr & vbLf & """" & "Digital marketing" & ":" & " " & "=" & vbLf & "also to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." &
"""" & vbCr & vbLf & """" & "Digital to " & vbLf & "connect communication" & "." & " " & """" & vbCr & vbLf & vbCr & vbLf & """" & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." & """" & vbCr & vbLf & """" & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." & """" & vbCr & vbLf & "Keywrod1" & ":" & " " & Chr(42) & Chr(42) & Chr(42) & " 2020" & "-" & "2021" & vbCr & vbLf & """" & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." & """" & vbCr & vbLf & "Keyword2" & vbCr & vbLf

---

Compare that with the range copied manually and pasted here, and a screenshot of the spreadsheet ( with wrap text enabled )

Code:

---

"234. *….Keywrod1:
2021-2022***"

"This also
text channel."
"Digital to
connect communication. "


"Digital to
connect communication.
This also
text channel."

Keywrod1:
Keyword2:  QWERTY


"2344. ….Keywrod1: *** 2020-2021
digital information
digital information"

"Digital marketing: =
also to
connect communication.
This also
text channel."
"Digital to
connect communication. "

"Digital to
connect communication.
This also
text channel."
"Digital to
connect communication.
This also
text channel."
Keywrod1: *** 2020-2021
"Digital to
connect communication.
This also
text channel."
Keyword2

---

https://i.postimg.cc/HkM0Yxqk/Screen...xt-Enabled.jpg

Conclusions
The row separator in the windows clipboard is that most typically used for a new line in computing, a Carriage return and a Line feed ( in VBA coding vbCr & vbLf ).
For a new line within a cell, we have the typical convention in Excel of just the Line feed ( in VBA coding, vbLf )
In the case of 2 or more lines within a cell, the entire string for the cell is enclosed in a pair of quotes. ( I expect this is to help avoid the vbLf being taken as a new row )

---

VBA row to cell1 reduced data.xls : https://app.box.com/s/qne60lkrfp30d50w444gedzjg6b7nyat
https://excelfox.com/forum/showthrea...ll=1#post16735

Here is an alternative single liner ( almost ## ) type solution to the last post. It was much simpler than I expected, and ends up much shorter than these solutions of mine usually do. (## There was a small snag, not solved yet, which means I have to do it in 2 code lines for now. I may take a look at that later here: https://excelfox.com/forum/showthrea...ll=1#post16655 )

Solution explanation.
Part 1. Background
This is all to do with
_ “my”** ____arrOut()=Index(ArrIn(), Rws(), Clms()) ______ type solutions, ( https://www.excelforum.com/excel-new...ml#post4571172 )
and also
_ using the Match in a similar way – ( some time ago I obsessed with trying out Application.Match where the first argument is an array, in a similar way to those of those array arguments Rws() and Clms() in Index. I got so obsessed I littered a sub forum with over long posts until they deleted them all and limited the post size to stop me doing it again. With hindsight, not a bad thing to do, as I could not see the wood for the trees back then. I can now, and its not at all difficult to understand, so I really don’t need all that crap anymore. Let me call that for now “my” **
________arrOut() = Match(arrArg1(), arrIn() , 0 ) ___ type solution.
( ** I use the word “my” lightly. – I learnt all this stuff from looking at stuff from Rick Rothstein and snb. ( I am not sure if they “invented it” , or got it from other peoples stuff. if I added anything “new” , it might be some of my detailed explanations, which whilst I don’t know if they are correct, they seem to be a valid theory as they go a long way to explain the results ) )


Here is a quick demo of how
_ my ____arrOut()=Match(arrArg1(), arrIn() , 0 ) ____ works
Ordinarily, or most usually the first argument is just one thing that you are looking for. As far as I know all documentation tells you that the way Match in Excel works is, ( simplified ) :
_... you look in the second argument array of things for the thing in the first argument, and , assuming you find it, return the position along where it is, pseudo like
_____ Match( b , { a, b, c } , 0 ) = 2
In the practice we sometimes, ( not always ) , find that things in Excel will work with array arguments and return a corresponding array of outputs. So taking that last example, pseudo like
_____ Match( {b, a} , { a, b, c } , 0 ) = {2, 1}

So that is a bit of theory out of the way. ( I have done a fuller explanation in a few places of how the Application.Index with Look Up Rows and Columns Arguments as VBA Arrays works in a few places
https://excelfox.com/forum/showthrea...ll=1#post16455
https://www.excelforum.com/excel-new...ml#post4571172 )

---

Part 2. Here is my solution examples
Refering to the first long macro below:

Rem1 is just making some stuff I need for the demo. I use the string example of “ZAC” as per the original OP example http://www.eileenslounge.com/viewtopic.php?f=30&t=38460 . For reasons given in the next bit, I make an array of the 26 Ascii Code numbers for the capital alphabet characters, A, B. C ….Z , Asskeys() = { 65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81 ,82,83,84,85,86,87,88,89,90 }
My array of the weights values, Weights(), for the characters will be the same size as Asskeys() and will have the corresponding weight value for each of the 26 characters in the same order.
Once again it will be clear why later. For now, the point is to have arrays of the same size with related things in the same order

Code:

---

' '  Ascii Code      65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90
' '                    A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z
' Let Weights() = Array(1, 5, 3, 1, 4, 3, 2, 1, 6, 4, 5, 3, 2, 1, 2, 3, 4, 5, 6, 7, 6, 5, 4, 3, 2, 2) 

---

Rem 2
I found a way on the internet to turn my string example into an array of single characters, which is what I will be feeding into my Match as first argument. ( Unfortunately it does not return in each element the character, but rather its Ascii Code. But for my purposes that’s just as good.

Rem 3 Match
This is the Match bit, and it tells me the position along where I find the three Ascii Code numbers of “ZAC” in the Ascii Code array, Asskeys()
We get from match here, a 3 element array, MtchRes(), of the position along, of the characters in “ZAC” in the array Asskeys(). We have organised that the array of weights is organised in the same order, so this will also be the position along of the corresponding weight number in the array of weights, Weights().
In the example we should have then an array like {26, 1, 3} _ ( if you have followed the logic so far, you can see this is like a pseudo Alphabet position of the characters, Z , A , and C __ (But don’t get confused with Ascii codes, which is pseudo like the official position of characters, and defined by some world standard, that Excel knows about. As example, capital A is listed as Ascii code 65, lowercase a is listed as 97 )

Rem 4 Index
The 3 element array of the position along, of the characters in “ZAC” in the array Asskeys(), is effectively the Clms() array we need for a __arrOut()=Index(ArrIn(), Rws(), Clms())__type solution, where the look up array, arrIn() , will be the weights array, Weights()
The returned array from Index , arrOut(), will be an array, of 3 numbers, which are the weight numbers for the example string “ZAC”.

Rem 5
Finally we simply sum the elements of the found weight values, as per the original OP request.

Code:

---

Sub AssKeys()
Rem 1 Make the arrays and other hard coded things for the demo
Dim AssKeys(1 To 26) As Long
Dim Eye As Long
    For Eye = 65 To 90 Step 1
    Let AssKeys(Eye - 64) = Eye
    Next Eye
' OR
'  Dim AssKeys() As Variant: Let AssKey() = Array(65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
Dim Weights() As Variant:
 '  Ascii Code      65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90
 '                    A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z
 Let Weights() = Array(1, 5, 3, 1, 4, 3, 2, 1, 6, 4, 5, 3, 2, 1, 2, 3, 4, 5, 6, 7, 6, 5, 4, 3, 2, 2)
Dim ZAC As String
 Let ZAC = "ZAC" ' This is a demo example text string
Rem 2 String to array
Dim arrZAC() As Byte: Let arrZAC() = StrConv(ZAC, vbFromUnicode) ' https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
Rem 3 Match
Dim MtchRes() As Variant
 Let MtchRes() = Application.Match(arrZAC(), AssKeys(), 0)
Rem 4 Index
Dim arrOut() As Variant
 Let arrOut() = Application.Index(Weights(), 1, MtchRes())
Rem 5
Dim Some As Long: Let Some = Application.Sum(arrOut())
End Sub

---

Here the shortening possibilities

Code:

---

Sub BeautifulAsskeys()
Rem 1 Make the arrays and other hard coded things for the demo
'Dim Asskeys(1 To 26) As Long
'Dim Eye As Long
'    For Eye = 65 To 90 Step 1
'    Let Asskeys(Eye - 64) = Eye
'    Next Eye
' OR
'  Dim AssKeys() As Variant: Let AssKey() = Array(65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'Dim Weights() As Variant:
' '  Ascii Code      65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90
' '                    A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z
' Let Weights() = Array(1, 5, 3, 1, 4, 3, 2, 1, 6, 4, 5, 3, 2, 1, 2, 3, 4, 5, 6, 7, 6, 5, 4, 3, 2, 2)
'Dim ZAC As String
' Let ZAC = "ZAC" ' This is a demo example text string
Rem 2 String to array
Dim arrZAC() As Byte: Let arrZAC() = StrConv("ZAC", vbFromUnicode) ' https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
Rem 3 Match
'Dim MtchRes() As Variant
' Let MtchRes() = Application.Match(arrZAC(), Asskeys(), 0)
' Let MtchRes() = Application.Match(StrConv(ZAC, vbFromUnicode), Asskeys(), 0)' this does not work
Rem 4 Index
'Dim arrOut() As Variant
' Let arrOut() = Application.Index(Weights(), 1, MtchRes())
Rem 5
Dim Some As Long: Let Some = Application.Sum(Application.Index(Array(1, 5, 3, 1, 4, 3, 2, 1, 6, 4, 5, 3, 2, 1, 2, 3, 4, 5, 6, 7, 6, 5, 4, 3, 2, 2), 1, Application.Match(arrZAC(), Array(65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90), 0)))
End Sub
'
Sub AsKeys()                                                      '  http://www.eileenslounge.com/viewtopic.php?p=297288#p297288
Dim arrZAC() As Byte: Let arrZAC() = StrConv("ZAC", vbFromUnicode) ' https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
Dim Some As Long: Let Some = Application.Sum(Application.Index(Array(1, 5, 3, 1, 4, 3, 2, 1, 6, 4, 5, 3, 2, 1, 2, 3, 4, 5, 6, 7, 6, 5, 4, 3, 2, 2), 1, Application.Match(arrZAC(), Array(65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90), 0)))
End Sub


---

---

** I use the word “my” lightly. – I learnt all this stuff from looking at stuff from Rick Rothstein and snb. ( I am not sure if they “invented it” , or got it from other peoples stuff. if I added anything “new” , it might be some of my detailed explanations, which whilst I don’t know if they are correct, they seem to be a valid theory as they go a long way to explain the results

Solution 1 for here
https://excelfox.com/forum/showthrea...cell-in-sheet2

Code:

---

Sub ConsolidateLines_Solution1() '  https://excelfox.com/forum/showthread.php/2815-Copy-data-from-multiple-rows-between-two-keyword-and-paste-the-data-in-row(s)-of-single-cell-in-sheet2
Rem 0 worksheets data info
Dim Ws1 As Worksheet, Ws2 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1): Set Ws2 = ThisWorkbook.Worksheets.Item(2)
Rem 1 Put data range in clipboards
 Ws1.UsedRange.Copy
Rem 2 get text data from 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/
Dim StringBack As String ' This has the entire text held for the range in the windows clipboard after a  .Copy
 objDataObject.GetFromClipboard: Let StringBack = objDataObject.GetText()
Rem 3 Initial to get started, finding first start point of text we want
Dim PosK1 As Long: Let PosK1 = InStr(1, StringBack, "Keywrod1", vbBinaryCompare)
Dim Pos1 As Long: Let Pos1 = InStrRev(Left(StringBack, PosK1), vbCr & vbLf, -1, vbBinaryCompare)
    If Pos1 = 0 Then Let Pos1 = 1 ' this is for the case if first  Keywrod1  is in the first cell with text in, so we have no new line character to find
 Let Pos1 = Pos1 + 2 ' If  Keywrod1  was not in the first cell with text in it, then we are at the start of a  vbCr & vbLf  pair. We don't want that pair so move to just past it
Rem 4 main text manipulation
'4a) will loop as long as we have a next pair of keywords
    Do While PosK1 <> 0  ' This the main outer loop will terminate if we find no new first keyword ################
    Dim PosK2 As Long: Let PosK2 = InStr(Pos1, StringBack, "Keyword2", vbBinaryCompare) ' we have the first keyword and the start of text in it, now we find the second keyworrd.....
        If PosK2 = 0 Then Exit Do ' A possible finish if a first keyword was found but no second one after -  a check that we have a matching next second keyword, so as not to loop further in the case of a first keyword towards the end of the data, but no final second keyword
    Dim Pos2 As Long: Let Pos2 = InStr(PosK1, StringBack, vbCr & vbLf, vbBinaryCompare) ' This will find the next cell defining new line characters after the second keyword.
    Dim celStr As String ' This is used to manipulate a string from a cell
    Let celStr = Mid(StringBack, Pos1, Pos2 - Pos1) ' We need the actial text we want. We have the start position. Pos1.  Our Pos2 is at the  start of the  vbCr & vbLf  pair, just one character above the last text we want.  So  Pos2-Pos1  willl give us out text length is what we want for the 3rd argumant of the VBA Mid function ( For the VBA Mid Function the first argument is the main text, the second argument from where we want to start taking the text )
    'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(celStr)    '  """" & "234" & "." & " " & Chr(42) & ChrW(8230) & "." & "Keywrod1" & ":" & " " & vbLf & "2021" & "-" & "2022" & Chr(42) & Chr(42) & Chr(42) & """"                                                                As example, this is what cell A2 gave  https://pastebin.com/raw/eutzzxHv
        If InStr(1, celStr, vbLf, vbBinaryCompare) <> 0 Then Let celStr = Replace(celStr, """", "", 1, 2, vbBinaryCompare) ' This should remove the enclosing quotes around multi line text
    'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(celStr)    '          "234" & "." & " " & Chr(42) & ChrW(8230) & "." & "Keywrod1" & ":" & " " & vbLf & "2021" & "-" & "2022" & Chr(42) & Chr(42) & Chr(42)
    Dim NewCelStr As String ' This is used to build the string for a new cell
    Let NewCelStr = NewCelStr & celStr & vbLf
'4b) We are stepping through all the cells within a keyword pair
        Do While Pos2 < PosK2 ' This keeps going untill we pass the current second keyword at  PosK2 ----|
        'Let celStr = "" ' We want to manipulate the next cell string'
        Let Pos1 = InStr(Pos2, StringBack, vbCr & vbLf, vbBinaryCompare) + 2 ' This should take us to the start of the text in the next cell
        Let Pos2 = InStr(Pos1, StringBack, vbCr & vbLf, vbBinaryCompare) ' This should take us to the end of the string in the next cell
        Let celStr = Mid(StringBack, Pos1, Pos2 - Pos1)
            If InStr(1, celStr, vbLf, vbBinaryCompare) <> 0 Then Let celStr = Replace(celStr, """", "", 1, 2, vbBinaryCompare) ' This should remove the enclosing quotes around multi line text
        Let NewCelStr = NewCelStr & celStr & vbLf
        Loop ' This is building the new cell string from cells in column A within the keywords ----------|
    'Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(NewcelStr)        '  "234" & "." & " " & Chr(42) & ChrW(8230) & "." & "Keywrod1" & ":" & " " & vbLf & "2021" & "-" & "2022" & Chr(42) & Chr(42) & Chr(42) & vbLf & vbLf & "This also " & vbLf & "text channel" & "." & vbLf & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & vbLf & vbLf & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." & vbLf & vbLf & "Keywrod1" & ":" & " " & vbLf & "Keyword2" & ":" & "  QWERTY" & vbLf
'4c)    ' At this point we have the complete text for a new single cell, (and an extra trailing  vbLf)
                                                                                                                  'If Left(NewcelStr, 2) = vbCr & vbLf Then Let NewcelStr = Mid(NewcelStr, 3) ' I am not too sure yet about this bodge. I seem to catch an extra row seperator, not sure why yet
    Let NewCelStr = Left(NewCelStr, Len(NewCelStr) - 1) ' Take off last trailing  vbLf
        If InStr(1, NewCelStr, vbLf, vbBinaryCompare) <> 0 Then Let NewCelStr = """" & NewCelStr & """" ' we need to enclose the final new cell string in a quote pair, so that the windows clipboard knows we have a single cell with multiline text
    Let NewCelStr = NewCelStr & vbCr & vbLf ' we add the line seperator that the windows clipboard recognises as a row in Excel
    ' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(NewcelStr) '  """" & "234" & "." & " " & Chr(42) & ChrW(8230) & "." & "Keywrod1" & ":" & " " & vbLf & "2021" & "-" & "2022" & Chr(42) & Chr(42) & Chr(42) & vbLf & vbLf & "This also " & vbLf & "text channel" & "." & vbLf & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & vbLf & vbLf & "Digital to " & vbLf & "connect communication" & "." & " " & vbLf & "This also " & vbLf & "text channel" & "." & vbLf & vbLf & "Keywrod1" & ":" & " " & vbLf & "Keyword2" & ":" & "  QWERTY" & """" & vbCr & vbLf
    ' we are now ready to move on to the text for the next new cell
    Dim Finalstr As String: Let Finalstr = Finalstr & NewCelStr ' we add the current complete new cell text to a final text which will be put in the windows clipboard
    Let PosK1 = InStr(Pos2, StringBack, "Keywrod1", vbBinaryCompare) '
        If PosK1 <> 0 Then Let Pos1 = InStrRev(Left(StringBack, PosK1), vbCr & vbLf, -1, vbBinaryCompare) + 2
    Let NewCelStr = ""
    Loop '  ### Main outer loop terminates when main text manipulation is finished ################################
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(Finalstr)
Rem 5 Put new text in clipboard
 objDataObject.Clear
 objDataObject.SetText Text:=Finalstr
 objDataObject.PutInClipboard
Rem 6  .Paste  out from windows clipboard
 Ws2.Columns(1).Clear
 Ws2.Paste Destination:=Ws2.Range("A2")
 Ws2.Columns(1).WrapText = False
End Sub


---

In support of this main forum post
https://eileenslounge.com/viewtopic.php?f=30&t=39339


We want to transform something like this…

Code	Date1	Date2	Form_Score	Question	Answer
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S1	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S2	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S3	NA
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S4	NA
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S5	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S6	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S7	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S8	NA
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S9	NA
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S10	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S11	NA
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S12	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S13	Yes
63646	2-5-2023 8:04:24 AM	1-31-2023 2:03:23 PM	100	S14	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S1	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S2	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S3	NA
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S4	NA
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S5	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S6	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S7	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S8	NA
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S9	NA
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S10	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S11	NA
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S12	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S13	Yes
63647	2-5-2023 8:09:16 AM	1-31-2023 12:35:46 PM	100	S14	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S1	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S2	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S3	NA
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S4	NA
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S5	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S6	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S7	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S8	NA
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S9	NA
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S10	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S11	NA
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S12	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S13	Yes
63650	2-5-2023 8:16:48 AM	1-31-2023 7:31:20 PM	100	S14	Yes
63653	2-5-2023 8:23:01 AM	1-31-2023 1:25:53 PM	100	S1	Yes
63653	2-5-2023 8:23:01 AM	1-31-2023 1:25:53 PM	100	S2	Yes
63653	2-5-2023 8:23:01 AM	1-31-2023 1:25:53 PM	100	S3	Yes
63653	2-5-2023 8:23:01 AM	1-31-2023 1:25:53 PM	100	S4	NA
63653	2-5-2023 8:23:01 AM	1-31-2023 1:25:53 PM	100	S5	Yes

Worksheet: Sheet1


…. To something like this

Code

Date1

Date2

Form_Score

S1

S2

S3

S4

S5

S6

S7

S8

S9

S10

S11

S12

S13

S14

63646

02-05-2023 08:04

01-31-2023 14:03

100

Yes

Yes

NA

NA

Yes

Yes

Yes

NA

NA

Yes

NA

Yes

Yes

Yes

63647

02-05-2023 08:09

01-31-2023 12:35

100

Yes

Yes

NA

NA

Yes

Yes

Yes

NA

NA

Yes

NA

Yes

Yes

Yes

63650

02-05-2023 08:16

01-31-2023 19:31

100

Yes

Yes

NA

NA

Yes

Yes

Yes

NA

NA

Yes

NA

Yes

Yes

Yes

63653

02-05-2023 08:23

01-31-2023 13:25

100

Yes

Yes

Yes

NA

Yes

….. One way to do it in the next post ( https://excelfox.com/forum/showthrea...ll=1#post19821
https://excelfox.com/forum/showthrea...ge52#post19821 )

….Continued from last post ( https://excelfox.com/forum/showthrea...ll=1#post19820
https://excelfox.com/forum/showthrea...ge52#post19820 )


The dictionary type way, like already done there by Hans ( https://eileenslounge.com/viewtopic....e527ed#p304935 ). is quite common and a good way. Often it’s the best , most efficient way.

Just for comparison to further the subject and discussion a bit , here’s another way.
To main differences, or rather two main things being done which are uncommon , or at least less common, as yet,

_1) Do While Loops
we use two Do While Loop things, one nested in the other.
The inner loop goes through each row in each of the ( in this example data ) 4 sections, and the outer Loop just takes us on to the next section. So effectively we loop through each data row. Potentially this my reduce the number of loops compared to other ways
The main thing that goes on is that a single string is built up, and that string contains most of the output data. This is arranged in a format such that the data column separator is the vbTab, and the row / line separator is the typical vbCr & vbLf pair
_2) Use of Clipboard
The string built up is put in the Clipboard. The Clipboard recognises the format as that of a Excel range, so we can paste that out.

Code:

---

Sub Transformator()
Rem 0 worksheets and data info
Dim Wss As Worksheet, Wst As Worksheet
 Set Wss = ThisWorkbook.Worksheets.Item(1): Set Wst = ThisWorkbook.Worksheets.Item(3)
Dim CuRe As Range
 Set CuRe = Wss.Range("A1").CurrentRegion
 Set CuRe = CuRe.Resize(CuRe.Rows.Count + 1) ' An extra empty row is often useful to make a  Do While Loop thing  of this sort teminate and not error when looking at the next after last
Dim Ars() As Variant
 Let Ars() = CuRe.Value
Rem 1 This is a  Do While Loop  nested in another  Do While Loop  In effect it loops through each data row and bulids up a final string in a form the clipboard will recognise as the final output data Excel range
Dim RCnt As Long: Let RCnt = 2
Dim strClp As String: Let strClp = "ReptClms"  ' The final string of data output to go in the clipboard to be pasted out.  I add a place with  ReptClms  whgich i replace later with the repeated columns
    Do While RCnt < UBound(Ars(), 1) ' Outer Loop - Loops once for each section
        Do '  While Ars(RCnt - 1, 1) = Ars(RCnt, 1) ' Inner Loop - loops in each section for as many rows in each section
        Let strClp = strClp & vbTab & Ars(RCnt, 6) ' This is buildiung the  Yes NA Maybe Real  string bit for each section
        Let RCnt = RCnt + 1 ' Move a row down in each section or effectiuvely to next section if condition below not met
        Loop While Ars(RCnt - 1, 1) = Ars(RCnt, 1)
        ' At this point we have the  Yes NA Maybe Real  (and also an extra  vbTab  at the start which we don't want), but  so need to add the other stuff for an output data row
      Let strClp = Replace(strClp, "ReptClms" & vbTab, Ars(RCnt - 1, 1) & vbTab & Ars(RCnt - 1, 2) & vbTab & Ars(RCnt - 1, 3) & vbTab & Ars(RCnt - 1, 4) & vbTab, 1, 1, vbBinaryCompare) ' Adding The first four columns of repeated values, and at the same time get rid of the unwanted  vbTab
      Let strClp = strClp & vbCr & vbLf ' This effectively ads a row in the form recognised by the Clipboard
      Let strClp = strClp & "ReptClms"
    ' Let RCnt = RCnt + 1 ' move a row down to the next section
    Loop ' While RCnt < UBound(Ars(), 1)
 Let strClp = Left(strClp, Len(strClp) - 10) ' This takes off the 11 characters of    vbCr vbLf R e p t C l m s
Rem 2 We have the main output , so stick it in the 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:=strClp
 objDataObject.PutInClipboard
Rem 3 Output main data output
 Wst.Paste Destination:=Wst.Range("A2")
Rem 4 the header stuff
'4a) copied headers
 Let Wst.Range("A1:D1").Value = Wss.Range("A1:D1").Value
'4b) The consequtive  S1  S2    etc stuf
Dim Ss() As Variant ' ' Example given data,  we need to get  S1 S2 .. S14
 Let Ss() = Evaluate("=" & """" & "S" & """" & "&" & "COLUMN(A:N)") ' This gets it
' So, Get the N from what we do know - knowing the column count number for example
Dim CL As String
 Let CL = Split(Cells(1, 18 - 4).Address, "$", 3, vbBinaryCompare)(1) ' = N  got from like second element, (1),  after spliting  $N$14  by the  $  ($N$14 is the address of  cell 1, 14        (0) is ""  (1) is N  (2) is 14      )
 Let CL = Split(Cells(1, 18 - 4).Address, "$")(1)
' 18 is the output data final column count
Dim rngOut As Range: Set rngOut = Wst.Range("A1").CurrentRegion
  Let CL = Split(Cells(1, rngOut.Columns.Count - 4).Address, "$", 3, vbBinaryCompare)(1) ' = N  got from like second element, (1),  after spliting  $N$14  by the  $  ($N$14 is the address of  cell 1, 14        (0) is ""  (1) is N  (2) is 14      )
  Let CL = Split(Cells(1, rngOut.Columns.Count - 4).Address, "$")(1) '
 ' Or
 Let Ss() = Evaluate("=" & """" & "S" & """" & "&" & "COLUMN(A:" & Split(Cells(1, rngOut.Columns.Count - 4).Address, "$")(1) & ")")
 Let Ss() = Evaluate("=" & """" & "S" & """" & "&" & "COLUMN(A:" & Split(Cells(1, Wst.Range("A1").CurrentRegion.Columns.Count - 4).Address, "$")(1) & ")")
 
 Let Ss() = Evaluate("=""S""" & "&" & "COLUMN(A:" & Split(Cells(1, Wst.Range("A1").CurrentRegion.Columns.Count - 4).Address, "$")(1) & ")")
 
 Let Wst.Range("E1").Resize(1, 14).Value = Evaluate("=""S""" & "&" & "COLUMN(A:" & Split(Cells(1, Wst.Range("A1").CurrentRegion.Columns.Count - 4).Address, "$")(1) & ")")
End Sub

---

Some notes in support of this main Forum Thread
https://www.eileenslounge.com/viewto...p?f=27&t=39784


later..