Assign string to cell the same way as Activesheet.PasteSpecial does-CodePudding

I would like to assign the value of a string to a cell in the same was as the ActiveSheet.PasteSpecial method does (I mean, the vbTab works as a tab, and the vbNewLine works as an enter), but without having to send the value of the string to the clipboard.

The routine below sends "one" to cell(1,1), "two" to cell(1,2), and "three" to cells(2,1). I would like to get the same result, but only by assigning the value of the string variable to the cell(1,1), without having to [1] send the string value to the clipboard, [2] selecting the desired cell, and [3] use the Activesheet.PasteSpecial method.

Sub Test_1() 'This uses the clipboard
    Dim MyData As DataObject, s as string
    Set MyData = New DataObject
    s = "one" & vbTab & "two" & vbNewLine & "three"
    MyData.SetText s
    MyData.PutInClipboard
    ActiveSheet.PasteSpecial Format:="Text"
End Sub

The next routine doesn't work. It sends the whole text to the cell(1,1) (the vbTab doesn't work, and the vbNewLine sends the word "three" to the second line of the cell(1,1).

Sub Test_2() 'This doesn't work as desired
    Dim s As String
    s = "one" & vbTab & "two" & vbNewLine & "three"
    Cells(1, 1) = s
End Sub

CodePudding user response：

Try this code:

Sub Test_2()
    Dim s As String
    s = "one" & vbTab & "two" & vbNewLine & "three"
    
    Call SubDistribution(s, Cells(1, 1))
    
End Sub

Sub SubDistribution(StrMessage As String, RngTopLeftCell As Range)
    
    'Declarations
    Dim StrString As String
    Dim RngSeed As Range
    Dim DblRowOffset As Double
    Dim DblColumnOffset As Double
    Dim DblTabPin As Double
    Dim DblNewLinePin As Double
    
    'Settings.
    StrString = StrMessage
    Set RngSeed = RngTopLeftCell
    
    'Cover the entire StrString.
    Do
        'Focusing on WorksheetFunction library.
        With Excel.WorksheetFunction
            
            'Oversetting DblTabPin and DblNewLinePin in case of error (no vbTab nor vbNewLine found).
            DblTabPin = Len(StrString)   1
            DblNewLinePin = Len(StrString)   1
            
            'Setting DblTabPin and DblNewLinePin as the next vbTab and vbNewLine position in StrString.
            On Error Resume Next
            DblTabPin = .Find(vbTab, StrString)
            DblNewLinePin = .Find(vbNewLine, StrString)
            On Error GoTo 0
            
            'Checking if the next vbNewLine is closer than the next vbTab.
            If DblTabPin > DblNewLinePin Then
                
                'Reporting the next chunk of StrString in the proper cell.
                RngSeed.Offset(DblRowOffset, DblColumnOffset).Value = Split(StrString, vbNewLine)(0)
                
                'Since we have encountered a vbNewLine, DblColumnOffset is set to 0 and DblRowOffset is increased by 1.
                DblColumnOffset = 0
                DblRowOffset = DblRowOffset   1
                
                'Cutting off the chunk of StrString just reported in the proper cell.
                StrString = .Substitute(StrString, Split(StrString, vbNewLine)(0) & vbNewLine, "", 1)
                
            Else
                
                'Reporting the next chunk of StrString in the proper cell.
                RngSeed.Offset(DblRowOffset, DblColumnOffset).Value = Split(StrString, vbTab)(0)
                
                'Since we have encountered a vbTab, DblColumnOffset is increased by 1.
                DblColumnOffset = DblColumnOffset   1
                
                'Cutting off the chunk of StrString just reported in the proper cell.
                StrString = .Substitute(StrString, Split(StrString, vbTab)(0) & vbTab, "", 1)
            End If
            
            
        End With
        
        'The only case allowing DblTabPin to be equal to DblNewLinePin is the one with no vbTab nor vbNewLine left in StrString. In such case the loop is left.
    Loop Until DblTabPin = DblNewLinePin
    
End Sub

CodePudding user response：

I guess there is no build-in function to do that. If you have the content "one" & vbTab & "two" & vbNewLine & "three" in one cell and would use copy & pasteSpecial, it would copy the whole content of the cell into one destination cell.

Try the following routine. It will split the string first into separate lines Split(s, vbNewLine) and then loop over the lines and split the content by Tabs Split(lines(lineNo), vbTab). The result of the 2nd split is then written into the cells of one row.

Sub InsteadOfPasteSpecial(s As String, startCell As Range)
    
    Dim lines() As String, lineNo As Long
    lines = Split(s, vbNewLine)
    For lineNo = 0 To UBound(lines)
        Dim cols() As String
        If lines(lineNo) <> "" Then
            cols = Split(lines(lineNo), vbTab)
            startCell.Offset(lineNo).Resize(1, UBound(cols)   1).Value = cols
        End If
    Next
End Sub