During reverse iteration of a range of cells (down to up going right to left), a row is inserted above the current one and and shifts down.
Sub ReverseIterateAndInsertRowRestart()
Dim ws As Worksheet
Dim rng As Range
Dim r As Long, c As Long
Dim columnToCheck As Long
Dim startRow As Long, startColumn As Long
' Set the worksheet and define the initial range
Set ws = ActiveSheet
Set rng = ws.Range("A1:E10") ' Adjust as needed
' Initialize starting row and column
startRow = rng.Rows.Count
startColumn = rng.Columns.Count
' Iterate through each row from bottom to top
For r = startRow To 1 Step -1
' Iterate through each column from right to left
For c = startColumn To 1 Step -1
' Check if the cell is blank
If Not IsEmpty(rng.Cells(r, c)) Then
' Insert a copy of the current row above
rng.Rows(r).Copy
rng.Rows(r).Insert Shift:=xlDown
rng.Cells(r, c).ClearContents ' Clear the specific cell in the copied row
' Update the range to include the new row
Set rng = ws.Range(rng.Cells(1, 1), rng.Cells(rng.Rows.Count, rng.Columns.Count))
' Adjust the row counter to account for the new row
r = r + 1
End If
Next c
Next r
End Sub
How would one ensure the iteration continues to the newly created row (as though it were already there)? Tried adding r=r+1
with no luck. Can't seem to update the loop.
A big thank you to @Ken White. Indeed to backdown rows, one has to monkey with the loop. Please see the following paragraph. Also a big thank you to @rotabor for his variants. His theorems pass the test but fail in practice. They don't take into account variadic rows (having different number of columns) and mixed. However, I would kindly ask that he doesn't delete them, because they are valuable learning materials. They have been immensely helpful. I will also state the same for the comments (all of them).
Because we are iterating backwards and inserting rows above the current row, we also have to push the limit (0) backwards to account for the added rows.
So here is a real-world use-case solution (simplified).
Option Explicit ' Force explicit variable declaration.
Sub ReverseIterateAndInsertRowRestart()
' Firstly, sort the fields if rows have mixed data to avoid duplicates.
' Use a procedure that looks good to you here: https://stackoverflow.com/questions/79082783.
Call SortBlanksOnTop
' Set up your variables and turn off screen updating.
Dim t As String
Dim a As Long, b As Long, c As Long, d As Long, e As Long
Dim r As Range ' Working range
Dim Cell As Range, Left As Range, LeftTop As Range
Dim insert As Boolean
Application.ScreenUpdating = False
' Set title for the range selection user dialog box.
t = "Selection Range"
' Request and store range from user.
Set r = Application.InputBox("Range", t, Application.Selection.Address, Type:=8)
' Initialize.
a = 0
b = r.Rows.Count
' Iterate through each row from bottom to top.
Do While b > a
' Assume no row has been added
insert = False
' Iterate through each column from right to left within that row
For c = r.Columns.Count To 1 Step -1
Set Cell = r.Cells(b, c)
' Calculate the relative column number within the range
d = Cell.Column - r.Columns(1).Column + 1
' This condition is based on the example data and layout provided below. Please adjust to your needs.
' Skip formular cells and only proceed if there are 2 additional columns to the left of the selected range.
If Not IsEmpty(Cell) And Not Cell.HasFormula And d > 2 Then
Set Left = Cell.Offset(0, -2)
' If row above exists, compare values
If Cell.Row > 1 Then
Set LeftTop = Left.Offset(-1, 0)
If Left.Value <> LeftTop.Value Then
' Indicate that a row has been added
insert = True
End If
Else
' Indicate that a row has been added
insert = True
End If
If insert Then
' Copy the current row
r.Rows(b).EntireRow.Copy
' Insert the copied row above the current row
r.Rows(b).EntireRow.insert Shift:=xlDown
' Clear the contents of the current column in the newly inserted row
Cell.Offset(-1, 0).ClearContents
' Calculate the relative row number within the range
e = Cell.Row - r.Rows(1).Row + 1
' Adjust the row counter
If e > 1 Then b = b + 1
' Restart loop for next row
Exit For
Else
' Exit current row
Exit For
End If
End If
Next c
' Count down
b = b - 1
' If a row was added, adjust the row limit to account for the new row
If insert And b <= 0 Then a = b - 1
Loop
' Turn screen updating back on.
Application.ScreenUpdating = True
End Sub
You may add your conditions as necessary to the IF
clause.
Example data (Uses a formula for the numbers)
Result