Insert new row, help

[Babi_mn]

I have 23019 row in my B column, and some of them are blank.
I want to add new blank row below each and every row except blank cells. Please help
PS i attached screenshot below (Column A is just numeric orders, ignore it please)

 

[kevin9999]

Please try the following on a copy of your workbook.

Option Explicit
Sub Insert_Rows()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change to actual sheet name ***
    Dim LRow As Long, LCol As Long, i As Long, j As Long
    LRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    Dim a, b, c
    a = ws.Range(ws.Cells(2, 2), ws.Cells(LRow, 2))
    ReDim b(1 To UBound(a, 1), 1 To 1)
    ReDim c(1 To UBound(a, 1), 1 To 1)
    For i = 1 To UBound(a, 1) - 1
        If a(i, 1) <> "" Then
            b(i, 1) = j + 1
            j = j + 1
        Else
            b(i, 1) = j
        End If
    Next i
    ws.Cells(2, LCol).Resize(UBound(b, 1), 1).Value = b
    
    For i = 1 To UBound(b, 1) - 1
        If b(i, 1) <> b(i + 1, 1) And a(i, 1) <> "" Then
            c(i, 1) = b(i, 1)
        End If
    Next i
    ws.Cells(LRow + 1, LCol).Resize(UBound(c, 1), 1).Value = c
    
    LRow = ws.Cells(Rows.Count, LCol).End(xlUp).Row
    ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
    order1:=xlAscending, Header:=xlNo
    ws.Columns(LCol).EntireColumn.ClearContents
    Application.ScreenUpdating = False
End Sub

 

[Babi_mn]

Please try the following on a copy of your workbook.

Option Explicit
Sub Insert_Rows()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change to actual sheet name ***
    Dim LRow As Long, LCol As Long, i As Long, j As Long
    LRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
   
    Dim a, b, c
    a = ws.Range(ws.Cells(2, 2), ws.Cells(LRow, 2))
    ReDim b(1 To UBound(a, 1), 1 To 1)
    ReDim c(1 To UBound(a, 1), 1 To 1)
    For i = 1 To UBound(a, 1) - 1
        If a(i, 1) <> "" Then
            b(i, 1) = j + 1
            j = j + 1
        Else
            b(i, 1) = j
        End If
    Next i
    ws.Cells(2, LCol).Resize(UBound(b, 1), 1).Value = b
   
    For i = 1 To UBound(b, 1) - 1
        If b(i, 1) <> b(i + 1, 1) And a(i, 1) <> "" Then
            c(i, 1) = b(i, 1)
        End If
    Next i
    ws.Cells(LRow + 1, LCol).Resize(UBound(c, 1), 1).Value = c
   
    LRow = ws.Cells(Rows.Count, LCol).End(xlUp).Row
    ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
    order1:=xlAscending, Header:=xlNo
    ws.Columns(LCol).EntireColumn.ClearContents
    Application.ScreenUpdating = False
End Sub

it is working , but it is not adding new row between number containing cell and blank cell, instead it just skipping it, could you please watch this?

 

[Babi_mn]

i mean, i need extra blank cell with old ones. If there was 1 blank then 2, was 2 then 3 etc...

 

[kevin9999]

it is not adding new row between number containing cell and blank cell

No, because you said:

add new blank row below each and every row except blank cells

which is somewhat ambiguous. So is it the case that you want a new blank row except where the entire row is already blank? Or is it the case that you want a new blank row added even if A & B are blank - but only one more blank row if that is the case?

 

[Babi_mn]

No, because you said:

which is somewhat ambiguous. So is it the case that you want a new blank row except where the entire row is already blank? Or is it the case that you want a new blank row added even if A & B are blank - but only one more blank row if that is the case?

my bad, I need only one more blank row even there is blank already.

 

[kevin9999]

So in your sample image - would you want a blank row below the "11" in column A - or not?

 

[Babi_mn]

So in your sample image - would you want a blank row below the "11" in column A - or not?

yes

 

[kevin9999]

OK, see if this does what you want. If it doesn't, then I'll need to see a before-and-after sample before I can progress any further.

Option Explicit
Sub Insert_Rows_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<-- *** Change to actual sheet name ***
    Dim LRow As Long, LCol As Long, i As Long, j As Long
    LRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    Dim a, b
    a = ws.Range(ws.Cells(2, 1), ws.Cells(LRow, 1))
    ReDim b(1 To UBound(a, 1), 1 To 1)
    For i = 1 To UBound(a, 1) ' - 1
            b(i, 1) = j + 1
            j = j + 1
    Next i
    ws.Cells(2, LCol).Resize(UBound(b, 1), 1).Value = b
    LRow = ws.Cells(Rows.Count, LCol).End(xlUp).Row + 1
    ws.Cells(LRow, LCol).Resize(UBound(b, 1), 1).Value = b
    
    LRow = ws.Cells(Rows.Count, LCol).End(xlUp).Row
    ws.Range(ws.Cells(2, 1), ws.Cells(LRow, LCol)).Sort Key1:=ws.Cells(2, LCol), _
    order1:=xlAscending, Header:=xlNo
    ws.Columns(LCol).EntireColumn.ClearContents
    Application.ScreenUpdating = False
End Sub

 

[Herakles]

I have 23019 row in my B column, and some of them are blank.
I want to add new blank row below each and every row except blank cells. Please help
PS i attached screenshot below (Column A is just numeric orders, ignore it please)

Try this on a copy of your data.

Make sure that the sheet is active.

Private Sub subInsertBlankRow()
Dim i As Integer
Dim lngLastRow  As Long
    
    With ActiveSheet
        lngLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With
        
    For i = lngLastRow To 2 Step -1
        If Len(Cells(i, 2).Value) > 0 Then
            Cells(i, 2).Offset(1, 0).EntireRow.Insert
        End If
    Next i

End Sub