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

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!

CodePudding user response：

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

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 cell and take value from 3rd cell above
            c.Insert xlShiftDown
            'c.offset(-1) = new cell
            'c.offset(-3) = value to copy
            c.Offset(-1).Value2 = c.Offset(-3).Value2
        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

CodePudding user response：

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

CodePudding user response：

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