Question

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

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

E.g。由于尝试将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并移动＆＃34; Q：AF＆＃34;在左边，然后我需要弄清楚如何让它循环，直到列P右边没有更多的数据。当出现这个问题时，从剪贴板粘贴多行到第一行丢失行线-breaks，它总是很多行。

有什么想法吗？

非常感谢！标记

    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

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

2 个答案: