VBA - put value in each empty row created

Question

I have a vba code that creates empty row after each row with value:

1. Row 1
2. Row 2
3. Row 3

Output Row 1

Row 2

Row 3

In the empty rows I want to insert value "check1", "check2", the auto increment of "check" and "autonumber"

To get a final output of the below:

1. Row 1
2. check1
3. row 2
4. check2
5. row n
6. check n

here is the code I have started:

Sub Insert_Blank_Rows()

 'Select last row in worksheet.
Selection.End(xlDown).Select

Do Until ActiveCell.Row = 1
     'Insert blank row.
    ActiveCell.EntireRow.Insert shift:=xlDown
     'Move up one row.
    ActiveCell.Offset(-1, 0).Select
Loop
End Sub

Answer 1

Here's a quick and easy and efficient way with only minimal adjustment to your current code.

Sub Insert_Blank_Rows()

Dim rng as Range
Set rng = Selection ' grab top most cell in range, you may want to actually refer to the actual cell.
rng.End(xlDown).Select 'Select last row in worksheet.

Do Until ActiveCell.Row = 1
     'Insert blank row.
    ActiveCell.EntireRow.Insert shift:=xlDown
     'Move up one row.
    ActiveCell.Offset(-1, 0).Select
Loop

'fill blanks with incremental checks
Dim rngBottom as Range
Set rngBottom = Cells(rows.Count,rng.Column).End(xlUp).Offset(1)

Range(rng, rngBottom).SpecialCells(xlCellTypBlanks).FormulaR1C1 = "=""Check""&ROW()/2"

End Sub

Answer 2

I'll throw in this solution, with no looping nor inserting it's very fast (less than 1 second for 20k rows)

Option Explicit

Sub main()
    Dim helperCol As Range

    With ActiveSheet.UsedRange
        Set helperCol = .Columns(.Columns.Count + 1)
    End With

    With Range(ActiveCell, ActiveCell.End(xlDown))
        .Offset(, helperCol.Column - .Column).Formula = "=ROW()"
        With .Offset(.Rows.Count)
            .Formula = "=CONCATENATE(""check"",ROW()-" & .Rows.Count & ")"
            .Value = .Value
            With .Offset(, helperCol.Column - .Column)
                .Formula = "=ROW()-" & .Rows.Count & "+ 0.1"
                .Value = .Value
            End With
        End With
        .Resize(2 * .Rows.Count, helperCol.Column - .Column + 1).Sort Key1:=helperCol.Resize(2 * .Rows.Count), Header:=xlNo
        helperCol.Resize(2 * .Rows.Count).Clear
    End With
End Sub

as per OP's request, it takes move from ActiveCell

Answer 3

So every other row is empty and you want to fill it? One way would be something like

finalRow = cells(1000000,1).end(xlup).row
yourIncrement = 1
for i = 1 to finalRow
    if isempty(cells(i,1)) then
        cells(i,1) = "check" & yourIncrement
        yourIncrement = yourIncrement + 1
    end if
next i

I am assuming your want to fill column 1 (A).

Answer 4

How's this?

Sub Insert_Blank_Rows()
Dim lastRow&, i&

'Assuming column A has the most data (if not change the `1` to whatever column # does have the most data
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

'Select last row in worksheet.
'Selection.End(xlDown).Select  ' Don't use `.Select`
i = 2
Do While i <= lastRow
    Rows(i).Select
    Rows(i).EntireRow.Insert shift:=xlDown
    Cells(i, 1).Value = "Check " & Cells(i - 1, 1).Value
    Cells(i, 1).Value = Cells(i, 1).Value
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    i = i + 2
Loop

End Sub

Answer 5

Here, I got one for you. I already tested it and work well for requirement.

Which is special in my code? My code will miss no row. Perfect auto-increment.

And I also reference from BruceWayne's code because I don't want to edit his own code.

Sub checkingData()

    Dim exeRow As Integer 'For indexing the executing row
    Dim lastRow As Integer 'For storing last row

    exeRow = 2 'Checking from first row

    'Assume that First Column has more data row than Other Column
    lastRow = Cells(Rows.Count, 1).End(xlUp).row

    'Loop from First Row to Last Row
    Do While exeRow <= lastRow + 1

        'Select data row
        Rows(exeRow).Select

        'Insert row below data row
        Rows(exeRow).EntireRow.Insert shift:=xlDown

        'Set auto-increment result
        Cells(exeRow, 1) = "Check " & (exeRow / 2)

        'Increase lastRow count because of adding blank row
        lastRow = lastRow + 1

        'Go to next data row
        exeRow = exeRow + 2

    Loop

End Sub