VBA to find a blank row, then copy two rows above it, then move to the next blank row

Question

Suppose you have Excel data in the format

Row A
Row B
Row C 
blank row
Row X
Row Y
Row Z
blank

I would like to 1) go to the row with the blank 2) copy the entire contents of the two rows above 3) paste the contents.

In the above example, the results would be

Row A
Row B
Row C
Row B
Row C
blank
Row X
Row Y
Row Z
Row Y
Row Z
blank

I am able to find the blanks. My code currently looks something like

Sub Find_Copy()

Dim rCell As Range
Dim r As Range
Dim r2 As Range

'We call the function and tell it to start the search in cell B1.
Set rCell = FindNextEmpty(Range("B8")) 'this is a separate function

'Shows a message box with the cell address. Right here is where
'you write the code that uses the empty cell.
rCell.Value = "Filled by macro 999"
MsgBox rCell.Address & " " & rCell.Value

    rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
    Selection.Copy
    Selection.Insert Shift:=xlDown
    
Set rCell = Nothing

End Sub

Can anyone help me get this sorted out? Thank you!

Ike · Answer 1 · 2021-11-06T11:08:48.220

The sub which does the work is enhanceList. It takes as parameter the range you want to work on.

The basic idea of my macro is to work from the bottom up while inserting the rows.

Option Explicit

Public Sub test_enhanceList()
Dim rg As Range
Set rg = table1.Range("A1:A8")    '<<< adjust to your needs

enhanceList rg

End Sub



' The sub which does the work
Private Sub enhanceList(rgToEnhance As Range)

Dim c As Range
With rgToEnhance
    'we will start at the end of the range
    Set c = .Cells(.Rows.Count)
End With

Dim i As Long

Do
    If LenB(c.Value2) = 0 Then  'test for empty cell
        For i = 1 To 2
            'insert empty row and take value from 3rd row above
            c.EntireRow.Insert xlShiftDown
            'c.offset(-1) = new cell
            'c.offset(-3) = value to copy
            c.Offset(-3).EntireRow.Copy c.Offset(-1)
        Next
    End If
    Set c = c.Offset(-1) 'set c to the cell above
Loop Until c.Row = rgToEnhance.Cells(1, 1).Row  'stop when first cell is reached

End Sub

This is way better than what I was doing. If I could check mark an answer here, it would be this one. — Dan, Nov 05 '21 at 19:13
Hi. Thank you so much for your help. However, i would like to copy the entire row. It seems like this is only copying cells. — dmt, Nov 06 '21 at 00:18
I updated the code - now the whole row is copied. But I am still only looking in the first cell of a row if it is empty. — Ike, Nov 06 '21 at 11:10

Dan · Answer 2 · 2021-11-05T17:17:54.370

Add this after your insert and you can get both rows B and C right. You'll have to add a loop with a range limit starting before your function call to get the next empty cell to add Y and Z and anything else that might come after. Post your function code and I can probably write a loop that will do it later.

rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Copy

rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Insert Shift:=xlDown

To choose the column you'd like to do this on by clicking on it change this line:

Set rCell = FindNextEmpty(ActiveCell.Offset(0, 0))

To this:

Set rCell = FindNextEmpty(Selection)

Then before running the macro, choose cell B1

Dan · Answer 3 · 2021-11-05T19:02:44.487

Rather than changing my answer, I added a new one. Added a couple lines to find the range of the data, and then looped through each cell in the range, testing for empty. It eliminates the need for the extra function.

Try this:

Sub Dan_Find_Copy()

Dim wkb As Workbook
Dim rCell As Range
Dim r As Range
Dim r2 As Range
Dim colNumber As Integer 'to store the column index
Dim rowNumber As Long    'to store the last row containing data
Dim i As Long 'iterator


'Need to get the range of the data
Set wkb = ActiveWorkbook
'store the column number of the selection
colNumber = Columns(Selection.Column).Column
'find the last row containing data
rowNumber = Cells(Rows.Count, colNumber).End(xlUp).Row
Set r = wkb.ActiveSheet.Range(Sheet1.Cells(1, colNumber), Sheet1.Cells(rowNumber, colNumber))

For Each rCell In r.Cells
    If rCell.Value = "" Then
        If MsgBox("Continue?", vbOKCancel, "Hello!") = vbOK Then

            'Shows a message box with the cell address. Right here is where
            'you write the code that uses the empty cell.
            rCell.Value = "Filled by macro 999"
            MsgBox rCell.Address & " " & rCell.Value
        
            rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
            Selection.Copy
            Selection.Insert Shift:=xlDown
        
            rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks
            Selection.Copy
        
            rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
            Selection.Insert Shift:=xlDown
        
            rCell.Select
            
        Else

            MsgBox ("You cancelled the process.")
            Exit For
            
        End If
        
    End If
    
Next rCell
    

Set rCell = Nothing
Set r = Nothing
Set wkb = Nothing

End Sub

Hi Thanks so much for all your efforts. Unfortunately i am not able to run this successfully. Suppose Sheet1 has the following values. B1=blank, B2=x, B3=y, B4=z, B5=blank, B6=x, B7=y, B8=z, B9=blank, B10=x, B11=y, B12=z. How would i get your code to run? Thanks again. — dmt, Nov 06 '21 at 00:24
Either select the second cell given that the first cell is empty or put a logical test at the beginning of each loop and move down one but honestly, I’d work with Ike’s suggestions instead of mine. His is shorter, simpler, and way cleaner. You could work in a test for that first empty cell too. — Dan, Nov 06 '21 at 01:09

VBA to find a blank row, then copy two rows above it, then move to the next blank row

3 Answers3