Excel宽格式转长格式VBA代码Find循环无法退出如何修改？

问题根因 #

你遇到的死循环核心原因有两个：

• 初始检索范围为整张工作表，每次粘贴操作会把包含Code的行放到A、B列底部，新写入的Code会被后续的FindNext检索到，导致永远无法匹配到初始记录的FirstAddress，循环无法终止
• 原始位置的Code被剪切清空后，FindNext遍历完所有原始待处理的Code后会重新从头检索，再次命中新粘贴到A/B列的Code，进入无限循环

修改方案 #

核心修改是把检索范围限定为前两列以外的区域，避免检索到后续粘贴到A/B列的Code，同时优化掉不必要的Select操作提升稳定性，修改后的完整代码如下：

Sub FindTextInSheets()
    Dim FirstAddress As String
    Dim rng As Range
    Dim pasteStart As Range
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 仅在C列及以后的区域查找Code，排除A、B列
    Set rng = ActiveSheet.Range("C:XFD").Find(What:="Code", _
                    After:=Range("C1"), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
    
    If Not rng Is Nothing Then
        FirstAddress = rng.Address
        Do
            ' 定位要剪切的区域：当前Code所在列+右侧1列，从Code行到最后有数据的行
            With rng
                Range(.Offset(0, 0), .End(xlDown).Offset(0, 1)).Cut
            End With
            
            ' 定位粘贴起始位置：A列最后一个有数据的行的下一行
            Set pasteStart = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            pasteStart.PasteSpecial
            
            ' 查找下一个Code
            Set rng = ActiveSheet.Range("C:XFD").FindNext(rng)
        Loop While Not rng Is Nothing And rng.Address <> FirstAddress
    End If
    
    ' 清空剪切板，恢复屏幕更新
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

修改说明 #

• 把查找范围从整表ActiveSheet.Cells调整为ActiveSheet.Range("C:XFD")，仅检索前两列以外的区域，彻底避免命中后续粘贴到A/B列的Code
• 移除了所有Select操作，直接操作单元格对象，避免选中状态变化导致的意外异常
• 新增了屏幕更新开关和剪切板清空逻辑，提升代码运行效率，避免操作后残留剪切选中状态

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