需要帮助循环基于所选行剪切/插入和删除单元格范围的宏

Question

此宏用于剪切，插入和删除工作簿的单元格范围部分。

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

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

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

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

我希望帮助循环此过程，直到 A-P 列之外没有数据。在这种情况下，单元格 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

Answer 1

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

第一个问题是它剪切了我突出显示的行的列 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

Answer 2

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

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