How to insert 15 blank rows every time a cell begins with "SB"

Question

How can I add 15 rows when my column H begins with 'SB' please?

This is a snippet of the data I have:

I need to insert 15 rows under each occurrence of a cell beginning with 'SB' in column H[Data.SOURCE]. Here are some examples highlighted, of when names begin with 'SB':

So it would begin to look like this:

I have tried lots of googling and this stack page, but it hasn't worked: How to insert a blank row based on cell value

Any help would be appreciated. Thank you!

Please share the code you have tried as text so we can copy/paste and fix it. — VBasic2008, Jul 19 '23 at 11:33
The question should be updated to include desired behavior, a specific problem or error, and **the shortest code necessary** to reproduce the problem. Looks like you are asking for a full development for free. — Foxfire And Burns And Burns, Jul 19 '23 at 12:33
The code I have tried was in the link that I sent. I will paste in as text shortly. I did include pictures for the desired behavior and the specific problem, perhaps I haven't been clear enough! I will try better next time. — Rebecca, Jul 19 '23 at 15:14

score 3 · Answer 1 · answered Jul 19 '23 at 12:27

Insert Blank Rows in an Excel Table

Sub InsertBlankRows()

    Const WORKSHEET_NAME As String = "Sheet1"
    Const TABLE_ID As Variant = "Table1"
    Const TABLE_COLUMN As Variant = "Data.Source"
    Const BEGINS_WITH As String = "SB" ' or e.g. "SB_HR_"
    Const INSERT_ROWS_COUNT As Long = 2
  
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Sheets(WORKSHEET_NAME)
    
    Dim lo As ListObject: Set lo = ws.ListObjects(TABLE_ID)
    
    ' Remove existing filters.
    If lo.ShowAutoFilter Then
        If lo.AutoFilter.FilterMode Then
            lo.AutoFilter.ShowAllData
        End If
    End If
    
    Dim lc As ListColumn: Set lc = lo.ListColumns(TABLE_COLUMN)
    
    Dim rg As Range: Set rg = lo.DataBodyRange
    Dim rCount As Long: rCount = rg.Rows.Count
        
    Dim cData()
        
    If rCount = 1 Then
        ReDim cData(1 To 1, 1 To 1): cData(1, 1) = lc.DataBodyRange.Value
    Else
        cData = lc.DataBodyRange.Value
    End If
    
    Application.ScreenUpdating = False
    
    Dim r As Long, rStr As String
    
    For r = rCount To 1 Step -1
        rStr = CStr(cData(r, 1).Value)
        If InStr(1, rStr, BEGINS_WITH, vbTextCompare) = 1 Then
            rg.Rows(r + 1).Resize(INSERT_ROWS_COUNT) _
                .Insert xlShiftDown, xlFormatFromLeftOrAbove
        End If
    Next r
    
    Application.ScreenUpdating = True
    
    MsgBox "Blank rows inserted.", vbInformation

End Sub

Note that you could use Application.Match as illustrated in this delete-rows code.

Thanks so much. Sorry, I'm not that great with Excel, or not as advanced as this. I have pasted this into a module in Visual Basic. I changed the bit at the top to point at my names: Const WORKSHEET_NAME As String = "Master_Avg_Route_Data" Const TABLE_ID As Variant = "Avg_Route_Data__11" Const TABLE_COLUMN As Variant = "Data.SOURCE" Const BEGINS_WITH As String = "SB" ' or e.g. "SB_HR_" Const INSERT_ROWS_COUNT As Long = 2' But it hits **Dim ws As Worksheet: Set ws = wb.Sheets(WORKSHEET_NAME) ** and I get an error. Any advice please? — Rebecca, Jul 19 '23 at 15:31
Check the worksheet name (maybe it has a leading or trailing space). If the code is not in the workbook containing this worksheet, a *"Subscript out of range"* error will occur. Then you should specify the workbook differently e.g.: `Set wb = Workbooks("Test.xlsx")`. — VBasic2008, Jul 19 '23 at 15:42

score 3 · Answer 2 · answered Jul 19 '23 at 13:09

Please, also test the next way. It places the range to be processed in an array (for faster processing) and creates a Union range of the necessary rows to be inserted. It makes insertion at the end, at once, being fast for a reasonable number of occurrences:

Sub insertRows(rng As Range, pref As String, noRows As Long)
  Dim URng As Range, arr, i As Long
  
  arr = rng.Value2
  For i = 1 To UBound(arr)
    If left(arr(i, 1), Len(pref)) = pref Then
      addToRange URng, rng.Parent.Range(i + rng.row & ":" & i + rng.row + noRows - 1)
    End If
  Next i
  
  If Not URng Is Nothing Then URng.insert xlDown
End Sub

It should be called in the next way (for variable insertions number):

Sub testInsertRows()
  Dim sh As Worksheet, lastR As Long, rng As Range
  
  Set sh = ActiveSheet 'use here the sheet you need
  lastR = sh.Range("H" & sh.rows.count).End(xlUp).row
  Set rng = sh.Range("H2:H" & lastR)
  insertRows rng, "SB", 3
End Sub

The necessary Sub to create the Union range (to be copied in a standard module, usually the one where the above code should also be):

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

score 2 · Accepted Answer · answered Jul 19 '23 at 11:41

2

Dim cRows as Long, i as long,j as Long
cRows=ActiveSheet.UsedRange.Rows.count
For i=cRows to 1 step-1
If Left(Cells(i,8),2)="SB" Then 
For j=1 to 15
Rows(i+1).EntireRow.Insert
next j
End If
Next i

Something like that

answered Jul 19 '23 at 11:41

IvanSTV

242
1
10

So I used this and it worked. For anyone else who is having this problem, use this code, but before it write "Sub testInsertRows()" and after it write "End Sub". THANK YOU IvanSTV!! – Rebecca Jul 19 '23 at 15:42

How to insert 15 blank rows every time a cell begins with "SB"

3 Answers3

Insert Blank Rows in an Excel Table