Excel VBA递增行号遍历A列时含ss字段截断功能失效问题

故障根因 #

原代码逐行处理逻辑完全不生效，核心问题如下：

1. 循环块内错误放置了Exit Do语句，第一次执行循环体就会直接跳出，行号变量根本没有递增机会，只会处理第1行就结束
2. 循环终止条件Cells(i, 1).value <> "*"不符合实际数据场景，目标数据里不存在单独的*作为行尾标记，既无法正确识别遍历终点，还可能触发死循环
3. 所有单元格操作没有绑定指定工作表对象，一旦执行时激活的不是目标工作表，就会读写错误位置的数据；行号变量定义为Integer类型，数据行数超过32767时会直接溢出报错；截取逻辑也没做逗号存在性校验，遇到异常格式会直接报错。

修复后完整代码 #

Sub loeschen()
    Dim sn As String
    Dim mac As String
    Dim Cache As String
    Dim i As Long
    Dim lastRow As Long

    Dim wbExcel As Workbook, wbText As Workbook
    Dim wsExcel As Worksheet
    Set wbExcel = ThisWorkbook '指定文本内容要粘贴到的目标工作簿
    Set wsExcel = wbExcel.Sheets(1) '指定要操作的目标工作表
    Set wbText = Workbooks.Open("U:\Desktop\Data.txt") '填写文本文件的完整路径

    wbText.Sheets(1).Cells.Copy wsExcel.Cells
    wbText.Close SaveChanges:=False

    '获取A列最后一个有数据的行号，作为遍历终点
    lastRow = wsExcel.Cells(wsExcel.Rows.Count, "A").End(xlUp).Row
    i = 1
    Do While i <= lastRow
        Cache = wsExcel.Cells(i, 1).Value
        '先判断单元格长度够不够，避免短文本调用Mid报错
        If Len(Cache) >= 29 And Mid(Cache, 28, 2) = "ss" Then
            '先判断是否存在逗号，避免InStr返回0时Left函数报错
            If InStr(1, Cache, ",") > 0 Then
                mac = Left(Cache, InStr(1, Cache, ",") - 1)
                wsExcel.Cells(i, 1).Value = mac
            End If
        End If
        i = i + 1
    Loop
    
    Application.DisplayAlerts = False
    wbExcel.SaveAs "U:\Desktop\SHCDataold" & Format(Date, "dd.mm.yyyy") & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True
End Sub

关键修复说明 #

• 移除了错误的Exit Do语句，保证循环可以逐行执行到最后一行
• 改用xlUp方法动态获取A列最后一行有数据的行号作为遍历终点，替代原来无效的*判断逻辑
• 所有单元格操作都明确绑定wsExcel工作表对象，避免激活表不对导致的读写错误
• 行号变量i改为Long类型，兼容大行数场景避免溢出
• 增加了文本长度校验、逗号存在性校验，避免异常格式数据触发运行时错误
• 保存文件时明确绑定目标工作簿、指定宏工作簿格式，避免对象不匹配、格式不符弹出多余提示

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