Loop is stopping for no apparent reason.

I have created a macro, to loop through a worksheet and create seperate worksheets based on the data. It works but after it gets to a certain point in the attached worksheet it just stops.


The worksheet is a dummy worksheet, but there are 19 sets of data on the worksheet. It stops after it copies the 9th set.

If anyone has any ideas, it would be greatly helpful.

Sub CreateBurndownChart()
'
' CreateBurndownChart Macro


'

'Copy and edit original sheet

Sheets("RiskListWithResponses").Copy After:=Sheets(1)
Sheets("RiskListWithResponses (2)").Name = "Copy"

Cells.Select
Application.CutCopyMode = False
Selection.Hyperlinks.Delete

With Selection.Font
    .Name = "Arial"
    .Size = 10
    .ThemeColor = xlThemeColorLight1

End With

Columns("C:C").Delete Shift:=xlToLeft
Columns("F:N").Delete Shift:=xlToLeft
Rows("1:7").Delete Shift:=xlUp
Columns("C:E").EntireColumn.AutoFit
Columns("B:B").ColumnWidth = 62.29
Cells.Select

With Selection
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .ShrinkToFit = False
    .MergeCells = False
End With

'Add borders
With Columns("A:E")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders()
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End With

'Loops to create new sheets

Dim RowCount As Integer
Dim RowA As Integer
Dim RowB As Integer
Dim LContinue As Integer
Dim LastRow As Integer

'Initiate Variables
RowA = 1
RowB = 1
LastRow = ActiveSheet.UsedRange.Rows.Count + 1

Do While RowA <> LastRow
    RowA = RowA + 1
    
    If (Range("A" & CStr(RowA))) <> "" Then
        RowB = RowA
        LContinue = True
        
        Do While LContinue = True
            RowB = RowB + 1
        
            If (Range("A" & CStr(RowB))) <> "" And (Range("B" & CStr(RowB))) <> "" Then
                 RowB = RowB - 1
                 LContinue = False
            
            ElseIf (Range("A" & CStr(RowB))) = "" And (Range("B" & CStr(RowB))) = "" Then
                 LContinue = False
            
            Else: LContinue = True
        
            End If
             
        Loop
        
'Create and edit new sheet

        
        Rows(RowA & ":" & RowB).Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        ActiveSheet.Paste
     
     
'Set up to rename sheets

        Columns("A:A").Delete Shift:=xlToLeft
   
        If (Range("A4")) = "" Then
            Application.DisplayAlerts = False
            ActiveWindow.SelectedSheets.Delete
            Application.DisplayAlerts = True
        Else
            Range("A1").Copy
            Range("G1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
                TrailingMinusNumbers:=True
                Columns("G:I").EntireColumn.AutoFit
          
            Do While IsNumeric([H1]) <> True
                Columns("H").Delete Shift:=xlToLeft
               
            Loop
            

            Range("A1").Select
            
             If Trim(Range("G1").Value) = "Risk" Then
                    ActiveSheet.Name = "R-" & Range("H1").Value
                ElseIf Trim(Range("G1").Value) = "Issue" Then
                    ActiveSheet.Name = "I-" & Range("H1").Value
                ElseIf Trim(Range("G1").Value) = "Opportunity" Then
                    ActiveSheet.Name = "O-" & Range("H1").Value
                End If
                
            Rows("1:3").Delete Shift:=xlToUp
            
            'Edit page
            Cells.Select
            With Selection
                .RowHeight = 37.5
                .VerticalAlignment = xlCenter
            End With
            
            Rows("1").RowHeight = 41.25
            
            Range("A1:D1").Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 12419407
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
  
            With Selection.Font
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = 0
            End With
            
            With Selection
                .HorizontalAlignment = xlCenter
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlLTR
                .MergeCells = False
            End With
            
            Columns("C:C").Select
            With Selection
                .Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                .ColumnWidth = 13.57
            End With
            Range("C1").Value = "Risk Rating Target"
            Columns("C").ColumnWidth = 13.57
            Columns("H:I").ColumnWidth = 13.57
            Columns("H").Select
            With Selection
                .HorizontalAlignment = xlGeneral
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            Range("I2:I4").Select
            With Selection
                .HorizontalAlignment = xlCenter
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            
            Range("I2").Interior.Color = 255
            Range("I3").Interior.Color = 65535
            Range("I4").Interior.Color = 5287936
            Range("I2").Value = "H(3e)"
            Range("I3").Value = "M(3c)"
            Range("I4").Value = "L(3b)"
            Range("H2").Value = "Complete"
            Range("H3").Value = "Active"
            Range("H4").Value = "Proposed"
            Range("A1").Select
            Sheets("Copy").Select
        End If
    End If
Loop

'Create Burndown files

Dim WbMain As Excel.Workbook
Dim Wb As Excel.Workbook
Dim sh As Excel.Worksheet
Dim DateString As String
Dim FolderName As String

Application.ScreenUpdating = False
Sheets("Copy").Visible = False
Sheets("RiskListWithResponses").Visible = False


DateString = Format(Now, "yy-mm-dd hh-mm-ss")
Set WbMain = ThisWorkbook
MkDir WbMain.Path & "\Burndown Charts " & DateString
FolderName = WbMain.Path & "\Burndown Charts " & DateString

For Each sh In WbMain.Worksheets
If sh.Visible = -1 Then
sh.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs FolderName & "\BurndownChart " & Wb.Sheets(1).Name & ".xlsx"
Wb.Close False
Set Wb = Nothing
End If
Next sh

Application.ScreenUpdating = True
Sheets("RiskListWithResponses").Visible = True
Sheets("RiskListWithResponses").Select

MsgBox "Look in " & FolderName & " for the files"


End Sub