Question

这很奇怪，因为它并不总是如此处所述。

此宏允许我在任何工作簿或工作表中选择多个（非相邻）行，将它们复制到剪贴板并删除行。

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

现在，通常，当我进入活动工作簿或工作表来粘贴行值时，行换行符将丢失，所有数据都将进入第一行。

由于这种情况经常发生，我设置了一个宏来轻松处理这个问题。

问题是，当我碰巧从剪贴板粘贴到一个空白的工作表中时，这只会起作用，所有行数据现在都在第1行。

如果我在一个随机点手动在另一个工作表或工作簿中插入4行，比如说在第20行到第24行，因为剪贴板中有4行数据;当然这个宏不起作用。

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

此解决方案也很接近，但同样缺乏随机灵活性。

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

因此，如果可能的话，我可能正在寻找两种解决方案。我奇怪的是，为什么有些时候使用Sub CopytoClipboard从剪贴板粘贴并删除行保留它们的换行符。

我知道何时发生这种情况，但不知道为什么。当我使用保存为文本文件（.txt或.csv）的源文件中的Sub CopytoClipboardandDelete时，我很少丢失行换行符。但是，当我使用Sub并粘贴到新工作簿或工作表时，再次使用此新数据集中的Sub并将其粘贴到另一个新工作簿或工作表上，它几乎每次都会丢失行换行符。

Answer 1

UPDATE：使用制表符分隔符设置时，我将所有预先存在的制表符替换为4个空格。

将多个（非相邻）范围复制到剪贴板作为逗号，制表符或HTML分隔表

注意：

工作表UsedRange以外的区域是从源ange
源范围中的每个区域都被分成行。 Range("C1:D1,F1")会产生2行C1:D1和F1。 8:8,4:4,6:6将添加3行，第一行是第8行，后面是第4行，最后是第6行。

样本数据

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

好的，我得到了它的工作，等等。现在我可以突出显示粘贴了多行的任何行;例如使用行A10-P10 +行Q10-AF10 +行AG10-AV10等突出显示行10 ...并复制列Q10-AF10，插入列A11-P11并删除列（“Q：AF”）。

我需要宏做的是循环此过程，直到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

Excel宏：丢失换行符将多个（非相邻）行粘贴到不同的工作簿中

2 个答案:

将多个（非相邻）范围复制到剪贴板作为逗号，制表符或HTML分隔表