Insert blank row after last series # in []

[BradMS]

how would I go about adding blanks rows after every square bracket when it switches from [1] , [2]....? (where the red line is)

I would like it to start at B2 after the series of [1] add a spaces then after the series of [2] add a space and so fourth.
Up until it reaches a blank and it ends.


View attachment 49417

This is what I found to work, but I need to tell it how many [1] I have. In the image I have [4]

Public Sub InsertRows()

Dim answer As Integer
Dim Lastrow As Long

'question
answer = InputBox("Total points?")

i = answer

x = 2 'Start Row
    
Range("A" & x, "F" & x).Insert

x = x + i + 1

Do Until IsEmpty(Cells(x, 1))

Range("A" & x, "F" & x).Insert

x = x + i + 1

Loop
  
End Sub

 

[JGordon11]

Sub AddRows()
    Dim i As Long, B, strRange As String
    B = Range(Cells(2, 2), Cells(2, 2).End(xlDown))
    For i = 2 To UBound(B)
        If Right(B(i, 1), 2) <> Right(B(i - 1, 1), 2) Then
            strRange = strRange & ",A" & i + 1 & ":F" & i + 1
        End If
    Next
    Range(Right(strRange, Len(strRange) - 1)).Insert
End Sub

 

[BradMS]

Sub AddRows()
    Dim i As Long, B, strRange As String
    B = Range(Cells(2, 2), Cells(2, 2).End(xlDown))
    For i = 2 To UBound(B)
        If Right(B(i, 1), 2) <> Right(B(i - 1, 1), 2) Then
            strRange = strRange & ",A" & i + 1 & ":F" & i + 1
        End If
    Next
    Range(Right(strRange, Len(strRange) - 1)).Insert
End Sub

Thankyou! i will try it later today!