Working with .Offset locations and running Macro through a loop

wittonline · Jul 15th 2016

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.

Code

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

Display More

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.)

wittonline · Jul 15th 2016

Re: Working with .Offset locations and running Macro through a loop

Here's one possible solution jic a visitor from the engines needs it...

Code

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

Display More

Working with .Offset locations and running Macro through a loop

Participate now!

Share