求助：VBA Do Until循环无法在B列遇"The End"时正确终止

现存逻辑bug #

• 终止条件判断错位：当前循环判断的是ActiveCell上一行的B列值，而非当前遍历行本身，首次循环选中B1时实际判断的是不存在的B0单元格，永远无法在命中"The End"时第一时间终止。
• 跨工作簿切换后未复位激活对象：循环内复制内容后激活了新工作簿，后续没有切回原工作表，ActiveCell会指向新工作簿单元格，导致行号偏移、判断失效，极易触发死循环。
• 写入逻辑错位：新工作簿粘贴位置没有主动偏移，每次复制的内容都会覆盖同一单元格。
• 路径拼接错误：保存路径末尾多了多余的单引号，会触发保存报错。
• 变量缺失声明：循环变量i未定义，容易出现隐性类型错误。

修正后代码 #

Option Explicit

Sub DoUntilDemo()
    Dim sTestFile As Workbook, sNewFile As Workbook
    Dim ws As Worksheet
    Dim currentRow As Long, newWriteRow As Long
    
    Application.ScreenUpdating = False
    ' 直接绑定对象，不依赖Active/Select避免状态错乱
    Set sTestFile = ActiveWorkbook
    Set sNewFile = Workbooks.Add
    
    ' 初始化新文件表头
    With sNewFile.Sheets(1)
        .Range("A1") = "Test"
        .Range("B1") = "YGTM"
        newWriteRow = 2 ' 从第二行开始写入数据
    End With
    
    ' 遍历原文件所有工作表
    For Each ws In sTestFile.Sheets
        currentRow = 1 ' 每个工作表从第1行开始遍历
        Do
            ' 命中终止标识立刻退出循环
            If ws.Range("B" & currentRow).Value = "The End" Then Exit Do
            ' C列非空时复制内容
            If ws.Range("C" & currentRow).Value <> "" Then
                ws.Range("C" & currentRow).Copy
                sNewFile.Sheets(1).Range("A" & newWriteRow).PasteSpecial xlPasteAll
                newWriteRow = newWriteRow + 1 ' 写入位置自动下移
            End If
            currentRow = currentRow + 1 ' 遍历行下移
        Loop
    Next ws
    
    ' 修正保存路径格式
    sNewFile.SaveAs CurDir & "\Please Work.xlsx"
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

关键调整说明 #

• 全程使用工作簿、工作表对象直接定位单元格，移除了所有Select/Activate调用，不会因为窗口激活状态变化导致逻辑错乱。
• 循环终止判断直接对准当前遍历行的B列值，命中"The End"时立刻退出，不会多执行无效逻辑。
• 单独维护新文件的写入行计数器，每次粘贴后自动下移，不会出现内容覆盖。
• 补全所有变量声明，增加Option Explicit强制变量校验，避免隐性错误。
• 修正了原保存路径的格式错误，避免保存失败。

内容的提问来源于stack exchange，提问作者SneakyKeys1025