Unable To Get Loop To Correctly End

Question

I have truly been stuck on this Do Until Loop and would appreciate some help on it. I want the loop to stop running once it reaches the string "The End" in column "B".

Sub DoUntil()

    Dim sTestFile, sNewFile
    Dim p As Integer
    
    Application.ScreenUpdating = False
    sTestFile = ActiveWorkbook.Name
    Workbooks.Add
    sNewFile = ActiveWorkbook.Name
    Range("A1") = "Test"
    Range("B1") = "YGTM"
    Range("A2").Select
    Windows(sTestFile).Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        Range("B1").Select
            Do Until (Range("B" & ActiveCell.Row - 1) = "The End")
                If Range("C" & ActiveCell.Row) <> "" Then
                    Range("C" & ActiveCell.Row).Copy
                    Windows(sNewFile).Activate
                    Range(ActiveCell, ActiveCell.Offset(0, 1)).PasteSpecial xlPasteAll
                End If
            ActiveCell.Offset(1, 0).Select
        Loop
    Next i
         
    ActiveWorkbook.SaveAs CurDir & "Please Work'"
    Application.ScreenUpdating = True
    
    

End Sub

Answer 1

Typically there's no need to Active/Select when using VBA in Excel: see here for more on that - How to avoid using Select in Excel VBA

Try this (untested)

Sub DoUntil()

    Dim wbSource As Workbook, ws As Worksheet, wsNew As Worksheet
    Dim c As Range, cDest As Range
    
    Application.ScreenUpdating = False
    Set wbSource = ActiveWorkbook            'get reference to active workbook
    Set wsNew = Workbooks.Add().Worksheets(1) 'reference first sheet in new workbook
    wsNew.Range("A1") = "Test"
    wsNew.Range("B1") = "YGTM"
    Set cDest = wsNew.Range("A2")
    
    For Each ws In wbSource.Worksheets        'loop all worksheets
        Set c = ws.Range("B1")
        Do While c.Value <> "The End"
            If Len(c.Offset(0, 1).Value) > 0 Then 'anything to copy?
                c.Resize(1, 2).Copy cDest
                Set cDest = cDest.Offset(1, 0) 'next paste location
            End If
            Set c = c.Offset(1, 0)
        Loop
    Next ws
         
    ActiveWorkbook.SaveAs wbSource.path & "\" & "Please Work.xlsx"
    
End Sub