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

[DocAElstein]

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

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