Need help looping this Macro process vs a one off

[wittonlin]

This Macro is used to cut, insert and delete a cell range section of a workbook.

The problem I was trying to solve and gave up with the lack of response in another thread is why copying multiple non-adjacent rows to the MS clipboard often loses their row line-breaks when pasting.

E.g. Since trying to paste 3 non-adjacent rows into row 10, 11 and 12, often puts all 3 rows into row 10 with one row in fields A10-P10, the next row in Q10-AF10 and the last row into AG10-AV10...

I edited the Macro below to fix this mistake when this happens.

So, for example, I can now highlight row 10 and run the macro to cut/insert the fields Q10-AF10 to A11-P11 and delete/shift left the blank fields now in Q10-AF10.

I'm hoping for help to loop this process until there's no data outside Column A-P. In this case, no data outside cell 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

 

[gallen]

Hello,

Your code seems a little confusing. I've changed it, to be a little more readable and it should work if I've understood your needs:

Sub FixAllOnLine1OneRowAtATimeInsertToNextRow()


'Dim copySheet As Worksheet
'Dim pasteSheet As Worksheet


Dim ws As Worksheet
Dim lNextRow As Long


    Application.ScreenUpdating = False
    
    'why do this when both are the same sheet?
    'Set copySheet = ActiveSheet
    'Set pasteSheet = ActiveSheet
    
    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).PasteSpecial xlPasteValues ' 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
End Sub

I've added comments to explain what each line of code is trying to achieve

I've commented out the bits you don't need so you can compare, and added a couple of lines.

Let me know if it works

 

[wittonlin]

Thank you Gallen! SO close!

Whereever I'm at in the worksheet, like highlighting and running the macro on row 10 or row 25, the cut Q:AF cell range now gets 'inserted' into row 2 or the 2nd row below any blank row above the selected row.

I need it to insert the cut Q:AF cell range directly into the very next row and push everything else down.

I got close by changing out and running the ws.Cells line and commenting out the next 2 lines in bold below; because this is how I understood >> ' Paste the copied values in to column "A" on next row? I know it's just changing 1 or 2 values but can't figure it out.

Finally I added, the only way I knew how, an ActiveCell.Offset to shift the active cell back up one row so I can single click to keep running the Macro until there's no more data right of column P.

Then if I can just get this to loop, at whatever row I initially hightlight, until there's no data to the right of column P!

Sub FixAllOnLine1OneRowAtATimeInsertToNextRow()

'Dim copySheet As Worksheet
'Dim pasteSheet As Worksheet

Dim ws As Worksheet
Dim lNextRow As Long

    Application.ScreenUpdating = False
    
    'why do this when both are the same sheet?
    'Set copySheet = ActiveSheet
    'Set pasteSheet = ActiveSheet
    
    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 single click to run again for multiple cell groups to apply fix.
End Sub

 

[wittonlin]

Sorry to be a bother. Does anyone have any ideas?

 

[gallen]

It's not very clear. Do you want it to loop as soon a cell is selected or to work of a button press? How would the loop work?

until there's no data to the right of column P!

You mean keep going until column Q is empty?

 

[wittonlin]

ok. I need to be able to highlight the row with the multiple cell ranges; E.g. Row 10 that has these cell ranges: A10:P10, Q10:AF10, AG10:AV10, etc. and run until there's only data in Columns A to P. Isn't "no data to the right of column P" the same as "until Q is empty"?

Do you already know the change(s) to the Offset so that the cut cell range, in the e.g. above Q10:AF10, is inserted one row below into cell range A11:P11?

Thank you so much!

 

[gallen]

Hello, I think I understand what you are trying to achieve but I've come at it from a whole different angle. This procedure is dynamic in that you can tell it how many columns you want to keep and it will get all columns after that an paste them underneath.

See if this is close. I've set the column number to 16 as that is the column number for column "P"

There's a function added too that just converts col number to a letter

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

Private Function ColNoToLetter(iCol As Integer) As String
'Function to convert a column number to a letter
Dim iAlpha As Integer
Dim iRemainder As Integer


   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ColNoToLetter = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ColNoToLetter = ColNoToLetter & Chr(iRemainder + 64)
   End If
   
End Function

 

[wittonlin]

Humm...I don't know what happened? Thank you so much for trying!

It errors on line: Range(sAddress).Copy

Maybe that's why it only partially finished. Initially it was perfect.

Now I have a .csv file with 20 records with data where it's supposed to be, in rows A:P.

Then I added 8 cell ranges in row 10 from Q10-AF10, then AG10-AV10, AW10-BM10 and so on where last cell with data is EN10.

Ok, then I highlighted row 10 and ran your Macro. Cell range Q10-AF10 was inserted in A11-P11; AG10-AV10 then inserted into A12-P12; AW10-BM10 was inserted into A13-P13 and this is where the wheels feel off. A blank row was inserted into A14-P14, unsure if it was added next or at the end, but the rest of the data (5 cell ranges) are gone. They were removed from the right side of column P, but now where in any row from A-P. So with the added space there's now 24 total rows.

Does that help out?

Thank you very much for trying to help here.

Mark

 

[gallen]

There's an issue with the function (that I stole from Microsoft) that return the wrong Cell Letters when it hits column 80.

I'll delve deeper and see if i can fix it.

 

[gallen]

I've changed the function. This one works, I've tested it up to column EN10. Apologies.

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