VBA finish loop if adjacing cells are empty

I’m creating a loop through a column on a separate sheet.
For every cell with content it creates a new sheet.

In the column there is an empty cell to create a separation.
I can’t change this because it’s an export.

The loop sees the empty cell and stops.
I need to let the loop know that it should stop if it comes across two adjacing cells.

This is the loop:

Option Explicit
Sub AddSheets()
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim rngCell As Range

Set wks = Sheets("Manual")
Set rngCell = wks.Range("B5")

While Not IsEmpty(rngCell)
    Set wksNew = ActiveWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count))
    wksNew.Name = rngCell.Value

    'do stuff with wksNew

    Set rngCell = rngCell.Offset(1)
Wend

End Sub

The column is pretty straightforward:
| A header |
| ——– |
| First |
| Second |
| Third |
| |
| Fourth |
| Fifth |
| Sixth |
| |
| |

>Solution :

You can change the loop to a Do … Loop then change the criteria to exit it, using a counter (here countOfEmpty) to record the number of rows with empty cells found … when that gets to 2, exit the loop

Option Explicit
Sub AddSheets()
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim rngCell As Range
Dim countOfEmpty As Long

Set wks = Sheets("Manual")
Set rngCell = wks.Range("B5")

Do While True
    If IsEmpty(rngCell) Then
        countOfEmpty = countOfEmpty + 1
        If countOfEmpty = 2 Then Exit Do
    Else
        countOfEmpty = 0
        Set wksNew = ActiveWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count))
        wksNew.Name = rngCell.Value

        'do stuff with wksNew

    End If
    Set rngCell = rngCell.Offset(1)
Loop

End Sub