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

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。我想将选中的单元格向下插入一行。我知道这是在Offset中的几个字符，我只是无法得到它。

然后，一旦它正常工作...说我突出显示第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