With some help, we've gotten REAL close!
The first issue is fixing the .Offset code so that the copy range ("Q" & ActiveCell.Row & ":AF" & ActiveCell.Row) is "inserted" into the very next row (A:P) below the initial selected row, rather than (A2:P2) where it goes now. < This location seems to change if there are any blank rows near the top of the worksheet fwiw.
Then I need some sort of loop that runs the macro until there's no more data in columns outside column P.
Got some help here, but not heard back in 18 hours.
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 'OR '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 single click to run again. End Sub
Here's a quick example for clarification.
1) Highlight, say, row 10 that includes cell ranges A10:P10, Q10:AF10, AG10:AV10, etc.
2) Copy the cell range Q10:AF10
3) Insert contents into cell range A11:P11
4) Delete columns ("Q:AF")
5) See code 'Added to move active cell up one row...
6) So I can run a loop until there's no more data outside of column P. (Stop when there's data only in columns A to P.)