遍历RD1工作表F列数值时出现无限循环问题求助

问题根源 #

你的代码在F列数值超过2个时触发无限循环，核心是以下几个逻辑漏洞：

• 遍历UUCCell的循环仅判断单元格是否为空，若后续列存在非空但非数值的内容，循环会无限制执行
• 最外层For i = 1 To counter2 * 2的循环次数错误，counter2从-1开始计数，实际有效UUC数量应为counter2 + 1，乘以2会导致循环次数溢出，触发内部逻辑混乱
• 内部Do While IsNumeric(sourceCell.Value) Or loopCount = 0的循环条件有缺陷，loopCount=0的兜底逻辑会让非数值单元格也触发循环，且未限制单元格遍历范围，若一直遇到数值会无限向下偏移
• 统计counter的循环用On Error Resume Next掩盖错误，无法正确终止循环

修正后的代码 #

Sub UpdateCalibrationCert5()

    Dim RD1Sheet As Worksheet
    Dim CalibrationCertSheet As Worksheet
    Dim sourceCell As Range, sourceCell2 As Range, targetCell As Range, targetCell2 As Range, insertRange As Range, startCell As Range, startSourceCell As Range, startSourceCell2 As Range, startTargetCell As Range, startTargetCell2 As Range
    Dim descriptionRange As Range, descriptionDestRange As Range, itemNumberCell As Range, itemDestCell As Range, afaaCell As Range, afaaDestCell As Range, offsetCell As Range, offsetDestCell As Range, afaaOffsetCell As Range, afaaOffsetDestCell As Range
    Dim cell As Range, copyRange As Range
    Dim counter As Long, counter2 As Long, loopCount As Long, i As Long, uucCount As Long
    
    ' 设置工作表
    Set RD1Sheet = ActiveWorkbook.Sheets("RD1")
    Set CalibrationCertSheet = ActiveWorkbook.Sheets("Calibration Cert.")
    
    ' 初始化计数器
    counter = -1
    counter2 = -1
    
    ' 从RD1工作表F28开始
    Dim setpointCell As Range
    Dim UUCCell As Range
    Set setpointCell = RD1Sheet.Range("F28")
    Set UUCCell = RD1Sheet.Range("F28")
    
    ' 遍历每7列统计有效UUC数量，增加列范围限制避免无限循环
    Do While Not IsEmpty(UUCCell) And UUCCell.Column <= RD1Sheet.Columns.Count
        If IsNumeric(UUCCell.Value) And Not IsError(UUCCell.Value) Then
            counter2 = counter2 + 1
        End If
        Set UUCCell = UUCCell.Offset(0, 7)
    Loop
    uucCount = counter2 + 1 ' 计算实际UUC数量
    
    ' 设置要插入的范围
    Set insertRange = CalibrationCertSheet.Range("N1:AX53")
    Set startCell = CalibrationCertSheet.Range("N1")
    
    ' 根据UUC数量插入列
    For i = 1 To counter2
        insertRange.Copy
        startCell.Offset(0, i * 37).Insert Shift:=xlToRight
    Next i
    
    ' 复制设备信息到证书
    Set UUCCell = RD1Sheet.Range("F28")
    Set afaaCell = RD1Sheet.Range("D19")
    Set afaaDestCell = CalibrationCertSheet.Range("S10")
    Set descriptionRange = RD1Sheet.Range("D13:D16")
    Set descriptionDestRange = CalibrationCertSheet.Range("U13:U16")
    Set itemNumberCell = RD1Sheet.Range("B19")
    Set itemDestCell = CalibrationCertSheet.Range("S13")
    Set offsetCell = RD1Sheet.Range("E18")
    Set offsetDestCell = CalibrationCertSheet.Range("AB22")
    Set afaaOffsetCell = RD1Sheet.Range("C18")
    Set afaaOffsetDestCell = CalibrationCertSheet.Range("S22")
    
    ' 遍历UUC复制信息，增加列范围限制
    Do While Not IsEmpty(UUCCell) And UUCCell.Column <= RD1Sheet.Columns.Count
        If IsNumeric(UUCCell.Value) And Not IsError(UUCCell.Value) Then
            descriptionDestRange.Value = descriptionRange.Value
            itemDestCell.Value = itemNumberCell.Value
            afaaDestCell.Value = afaaCell.Value
            afaaOffsetDestCell.Value = afaaOffsetCell.Value
            offsetDestCell.Value = offsetCell.Value
    
            ' 偏移目标单元格
            Set afaaDestCell = afaaDestCell.Offset(0, 37)
            Set offsetDestCell = offsetDestCell.Offset(0, 37)
            Set afaaOffsetDestCell = afaaOffsetDestCell.Offset(0, 37)
            Set descriptionDestRange = descriptionDestRange.Offset(0, 37)
            Set itemDestCell = itemDestCell.Offset(0, 36)
        End If
    
        ' 偏移源单元格
        Set UUCCell = UUCCell.Offset(0, 7)
        Set afaaCell = afaaCell.Offset(0, 4)
        Set offsetCell = offsetCell.Offset(0, 7)
        Set afaaOffsetCell = afaaOffsetCell.Offset(0, 7)
        Set descriptionRange = descriptionRange.Offset(0, 7)
        Set itemNumberCell = itemNumberCell.Offset(0, 7)
    
        Application.CutCopyMode = False
    Loop

    ' 统计F列有效设定点数量，用范围检查替代错误捕获
    Do While IsNumeric(setpointCell.Value) And setpointCell.Row <= RD1Sheet.Rows.Count
        counter = counter + 1
        Set setpointCell = setpointCell.Offset(12, 0)
    Loop

    ' 复制并插入设定点行
    Set copyRange = CalibrationCertSheet.Range("S21:AR21")
    For i = 1 To uucCount
        copyRange.Copy
        copyRange.Resize(counter).Insert Shift:=xlDown
        Set copyRange = copyRange.Offset(-counter, 37)
    Next i
    
    ' 初始化源和目标单元格
    Set startSourceCell = RD1Sheet.Range("F28")
    Set startSourceCell2 = RD1Sheet.Range("G26")
    Set startTargetCell = CalibrationCertSheet.Range("S21")
    Set startTargetCell2 = CalibrationCertSheet.Range("Y21")
    
    ' 外层循环：遍历每个UUC，使用实际UUC数量
    For i = 1 To uucCount
        Set sourceCell = startSourceCell
        Set sourceCell2 = startSourceCell2
        Set targetCell = startTargetCell
        Set targetCell2 = startTargetCell2
        
        loopCount = 0
        ' 内层循环：复制设定点，增加范围检查避免无限循环
        Do While sourceCell.Row <= RD1Sheet.Rows.Count And targetCell.Row <= CalibrationCertSheet.Rows.Count
            If Not IsNumeric(sourceCell.Value) Then
                Exit Do
            End If
            
            targetCell.Value = sourceCell.Value
            targetCell2.Value = sourceCell2.Value
            
            Set sourceCell = sourceCell.Offset(12, 0)
            Set sourceCell2 = sourceCell2.Offset(12, 0)
            Set targetCell = targetCell.Offset(1, 0)
            Set targetCell2 = targetCell2.Offset(1, 0)
            
            loopCount = loopCount + 1
        Loop
        
        ' 偏移源和目标单元格到下一个UUC，统一偏移量为37
        Set startSourceCell = startSourceCell.Offset(0, 7)
        Set startSourceCell2 = startSourceCell2.Offset(0, 7)
        Set startTargetCell = startTargetCell.Offset(0, 37)
        Set startTargetCell2 = startTargetCell2.Offset(0, 37)
    Next i
    
    MsgBox "证书已完成！", vbInformation
End Sub

关键修改说明 #

1. 限制循环边界：所有Do While循环增加工作表行列范围判断，避免单元格偏移超出工作表导致无限循环
2. 修正循环次数：外层循环改用实际UUC数量uucCount，避免循环次数溢出
3. 简化循环条件：移除loopCount=0的兜底逻辑，仅处理数值单元格，避免非数值单元格触发错误偏移
4. 统一偏移量：将目标单元格偏移量从32改为37，和插入列的偏移量保持一致，确保单元格定位准确
5. 替换错误处理：移除On Error Resume Next，改用明确的范围检查，避免掩盖潜在问题

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