Excel Macro: Lose line breaks pasting multiple (non-adjacent) rows into a different workbook

Question

This is odd, because it doesn't always happen as described here.

This Macro allows me to select multiple (non-adjacent) rows in any Workbook or Worksheet, copy them to clipboard and delete the rows.

Sub CopytoClipboardandDelete()

    Dim obj As New MSForms.DataObject
    Dim X, str As String
    Dim count As Integer

    count = 0

    For Each X In Selection

        count = count + 1

        If X <> "" Then
            If count = 1 Then

                str = str & X
            Else
                str = str & Chr(9) & X

            End If
        End If

        If count = 16384 Then
            str = str & Chr(13)
            count = 0
        End If

    Next

    obj.SetText str
    obj.PutInClipboard

    Selection.Delete Shift:=xlUp

End Sub

Now, often, when I get to the Active Workbook or Worksheet to paste the row values the row line breaks are lost and all the data goes into the first single row.

Since this occurs so often, I setup a Macro to easily deal with this.

The problem is that this ONLY works when I happen to paste from the clipboard into a blank Worksheet with all the row data now in Row 1.

If I manually insert 4 rows in the other Worksheet or Workbook at a random point, say into Row 20 to Row 24, since there's 4 rows of data in the clipboard; of course this Macro won't work.

Sub FixAllOnLine1OneRowAtATimeToFirstEmpty()

Application.ScreenUpdating = False
    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet

    Set copySheet = ActiveSheet
    Set pasteSheet = ActiveSheet

    copySheet.Range("Q1:AF1").Copy
    pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).PasteSpecial     xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Columns("Q:AF").Select
    Selection.Delete Shift:=xlToLeft

End Sub

This solution is also close, but again lacks the random flexibility.

Split single row into multiple rows based on cell value in excel

So potentially I'm looking for either solution or both if possible. I am oddly curious why certain times pasting from the clipboard using the Sub CopytoClipboardandDelete the rows preserve their line breaks.

I have a clue to when this occurs, but no idea why. When I use the Sub CopytoClipboardandDelete from the source file that was saved as a text file (.txt or .csv) I rarely lose the row line breaks. But when I use the Sub and paste to a new workbook or worksheet, then use the Sub again from this new dataset and paste it on to another new workbook or worksheet it loses the row line-breaks nearly every time.

Answer 1

UPDATE: When using the Tab delimiter setting, I replace all the preexisting Tabs with 4 spaces.

Copy multiple (non-adjacent) ranges to Clip Board as Comma, Tab Or HTML Delimited Table

Notes:

• Areas outside the worksheets UsedRange are cropped from source ange
• Each Area in the source range is is broken into rows. Range("C1:D1,F1") will result in 2 rows C1:D1 and F1. 8:8,4:4,6:6 will add 3 rows with the first row being row 8 followed by row 4 and finally row 6.

Sample Data

Option Explicit

Enum ClipTableEnum
    eCSV
    eHTML
    eTab
End Enum

Sub PutRangeIntoClipBoard(rSource As Range, Optional clipEnum As ClipTableEnum = eTab, Optional DebugPrint As Boolean = False)

    Dim a, arr
    Dim x As Long, rwCount As Long
    Dim r As Range, rngRow As Range
    Dim s As String

    With rSource.Worksheet
        Set r = Intersect(rSource, .UsedRange)

        If InStr(r.Address(False, False), ",") Then

            arr = Split(r.Address(False, False), ",")

        Else
            ReDim arr(0)
            arr(0) = r.Address(False, False)
        End If

        For Each a In arr
            rwCount = .Range(a).Rows.count
            For x = 1 To rwCount
                Set rngRow = .Range(a).Rows(x)

                s = s & get1dRangeToString(rngRow, clipEnum)

            Next

        Next

    End With

    If DebugPrint Then Debug.Print vbCrLf & s

    PutInClipBoard s
End Sub


Function get1dRangeToString(rSource As Range, Optional clipEnum As ClipTableEnum = eTab) As String
    Dim arr
    Dim s As String
    Dim x As Long

    If rSource.Cells.count = 1 Then
        ReDim arr(0)
        arr(0) = rSource.Value
    Else
        arr = WorksheetFunction.Transpose(rSource)
        arr = WorksheetFunction.Transpose(arr)
    End If

    Select Case clipEnum

        Case ClipTableEnum.eCSV

            s = """" & Join(arr, """,""") & """" & vbCrLf

        Case ClipTableEnum.eHTML

            s = "<TR><TD>" & Join(arr, "</TD><TD>") & "</TD></TR>" & vbCrLf

        Case ClipTableEnum.eTab

            For x = LBound(arr) To UBound(arr)
                arr(x) = Replace(arr(x), vbTab, "    ")
            Next

            s = Join(arr, vbTab)

            s = s & vbCrLf

    End Select

    get1dRangeToString = s

End Function

Sub PutInClipBoard(s As String)
    Dim clip As DataObject
    Set clip = New DataObject

    clip.SetText s
    clip.PutInClipBoard

    Set clip = Nothing

End Sub

Answer 2

Ok I got it to work, sort-of. Now I can highlight any row that has the multiple rows pasted in; e.g. Highlight Row 10 with Row A10-P10 + Row Q10-AF10 + Row AG10-AV10 etc...and it copies Column Q10-AF10, inserts into Column A11-P11 and deletes Columns("Q:AF").

What I need the Macro to do is loop this process until there's no data outside Column A-P.

Sub FixAllOnLine1OneRowAtATimeInsertToNextRow()

Application.ScreenUpdating = False
    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet

    Set copySheet = ActiveSheet
    Set pasteSheet = ActiveSheet

    copySheet.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Copy
    Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Offset(1).Select

    pasteSheet.Cells(ActiveCell.Row, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Columns("Q:AF").Select
    Selection.Delete Shift:=xlToLeft

End Sub