0

该宏用于剪切、插入和删除工作簿的单元格区域部分。

我试图解决并放弃在另一个线程中缺乏响应的问题是，为什么将多个不相邻的行复制到 MS 剪贴板通常会在粘贴时丢失它们的行换行符。

例如，由于尝试将 3 个不相邻的行粘贴到第 10、11 和 12 行，通常将所有 3 行放入第 10 行，其中一行在字段 A10-P10 中，下一行在 Q10-AF10 中，最后一行放入 AG10-AV10 ...

当发生这种情况时，我编辑了下面的宏来修复这个错误。

因此，例如，我现在可以突出显示第 10 行并运行宏以剪切/插入字段 Q10-AF10 到 A11-P11，然后删除/移左 Q10-AF10 中的空白字段。

我希望帮助循环这个过程，直到 Column AP 之外没有数据。在这种情况下，单元格 P10 之外没有数据。

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
4

2 回答 2

0

好的，我取得了一些进展。我只有一个超级简单的问题，然后我需要循环它。

第一个问题是它正确地剪切了我突出显示的行的 Q:AF 列并将整个 Q:AF 列向左移动，但是它将剪切的单元格插入到固定范围 A2:P2 中。我想从我的选择中将剪切的单元格插入一行。我知道这是偏移量中的几个字符，我就是无法理解。

然后，一旦它正常工作......假设我突出显示第 10 行，它会剪切 Q10:AF10 而是将单元格插入 A11:P11 并将“Q:AF”向左移动，然后我需要弄清楚如何得到它循环，直到 P 列右侧没有更多数据。当出现此问题时，将剪贴板中的多行全部粘贴到第一行丢失行换行符时，总是有很多行。

有任何想法吗？

非常感谢！标记

    Sub FixAllOnLine1OneRowAtATimeInsertToNextRow()

    Dim ws As Worksheet
    Dim lNextRow As Long

        Application.ScreenUpdating = False

        Set ws = ActiveSheet

        ws.Range("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row).Copy 'Copy the row of the selected cell from Q:AF

        ws.Range("Q" & ActiveCell.Row & ":AF" &  ActiveCell.Row).Offset(1).Select 'Select the cells you have just copied.  Not needed

        ws.Cells(ActiveCell.Row, 1).End(xlUp).Offset(1, 0).Insert xlShiftDown ' Paste the copied values in to column "A" on next row?
        'lNextRow = ws.Range("A" & Rows.count).End(xlUp).Row + 1 'Get Next Row number
        'Range("A" & lNextRow).PasteSpecial xlPasteValues

        Application.CutCopyMode = False
        Range("Q:AF").Delete Shift:=xlToLeft
        'Columns("Q:AF").Select
        'Selection.Delete Shift:=xlToLeft

        Application.ScreenUpdating = True
        ActiveCell.Offset(RowOffset:=-1, columnOffset:=0).Activate 'Added to move active cell up one row to run it again for multiple groups to apply fix.

    End Sub
于 2016-07-14T07:20:34.097 回答
0

这是另一个方向的解决方案，以防引擎中的某个人需要它...

Sub ReduceNoOfColumns()

Dim iRow As Integer 'Row to be manipulated
Dim iRowToPasteTo 'Row number to paste the copied cells
Dim iCurCol As Integer 'Current Column number of first cell with a value to cut
Dim NoOfCols As Integer 'integer to hold max number of columns
Dim sAddress As String

    iRow = ActiveCell.Row
    iRowToPasteTo = iRow + 1
    NoOfCols = 16 'Set this number to the total number of columns you wish to have (in your case 16)
    iCurCol = NoOfCols + 1

    Do Until Cells(iRow, iCurCol).Value = ""  'Keep looping until we get to an empty column
        sAddress = ColNoToLetter(iCurCol) & iRow & ":" & ColNoToLetter(iCurCol + NoOfCols - 1) & iRow
        Rows(iRowToPasteTo & ":" & iRowToPasteTo).Insert Shift:=xlDown
        Range(sAddress).Copy
        Range("A" & iRowToPasteTo).PasteSpecial xlPasteAll
        Range(sAddress).Clear

        iCurCol = iCurCol + NoOfCols
        iRowToPasteTo = iRowToPasteTo + 1
    Loop

End Sub

Function ColNoToLetter(iCol As Integer) As String
Dim vArr
vArr = Split(Cells(1, iCol).Address(True, False), "$")
ColNoToLetter = vArr(0)
End Function
于 2016-07-15T18:45:53.490 回答