VBA表格数据向下移位问题求助（含正反循环需求）

需求说明 #

• 遍历数据表某列ID，检测字符串特定段（等号前最后2位）的重复项
• 当检测到该段不匹配时，将最后一个重复项下方的所有数据向下移位4行，使重复项后保留3个空行
• 仅处理非空且长度大于6的ID单元格

兼容性要求 #

• 避免插入整行，允许通过下移方式实现空行
• 尽量不使用Select方法
• 禁用应用程序级的启用/禁用设置（如ScreenUpdating）
• 减少单个单元格的修改操作，优先整区域操作

当前问题 #

现有代码中的反向循环逻辑存在错误，无法正确实现数据移位效果，附上代码寻求修复方案：

Sub shiftValues()

Dim ws1 As Worksheet
    Set ws1 = Worksheets("Tab1=Raw Data")
Dim lastRow As Variant
    lastRow = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row


Dim cell As Range
Dim rng As Range
    Set rng = ws1.Range("A16:A" & lastRow)
Dim oldString As String
Dim newString As String
    newString = "newString"
Dim oldRow As Integer
    oldRow = 15 'Start of table

Dim beforeEqual() As String
    beforeEqual = Split(ws1.Range("A15").Value, "=")
Dim tar As Long    

    For Each cell In rng
        oldString = Right(beforeEqual(0), 2)
        If cell.Value <> vbNullString And Len(cell.Value) > 6 Then
            beforeEqual = Split(cell.Value, "=")
            newString = Right(beforeEqual(0), 2)
            
            If newString <> oldString And cell.Row > 15 Then
                oldString = newString
                oldRow = cell.Row
                    tar = lastRow
                    Do Until tar = oldRow
                        Range("A" & tar + 4).Value = Range("A" & tar).Value
                        Range("A" & tar).ClearContents
                        tar = tar - 1
                    Loop
            End If
        End If
    Next cell
End Sub

修复后的代码及说明 #

Sub ShiftValues()
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("Tab1=Raw Data")
    
    Dim lastRow As Long
    Dim currentRow As Long
    Dim oldSuffix As String
    Dim newSuffix As String
    Dim splitParts() As String
    
    ' 初始化起始后缀（A15的等号前最后2位）
    splitParts = Split(ws1.Range("A15").Value, "=")
    oldSuffix = Right(splitParts(0), 2)
    lastRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
    
    ' 反向遍历：避免移位后行号变化影响循环逻辑
    For currentRow = lastRow To 16 Step -1
        With ws1.Range("A" & currentRow)
            If .Value <> vbNullString And Len(.Value) > 6 Then
                splitParts = Split(.Value, "=")
                newSuffix = Right(splitParts(0), 2)
                
                ' 检测到后缀变化时执行移位
                If newSuffix <> oldSuffix Then
                    ' 定义移位区域：按需调整列范围（示例为A-Z列）
                    Dim shiftRng As Range
                    Set shiftRng = ws1.Range("A" & currentRow & ":Z" & lastRow)
                    
                    ' 整区域复制+清除，减少单个单元格操作
                    shiftRng.Copy ws1.Range("A" & currentRow + 4)
                    shiftRng.ClearContents
                    
                    ' 更新最后行号和基准后缀
                    lastRow = lastRow + 4
                    oldSuffix = newSuffix
                End If
            End If
        End With
    Next currentRow
End Sub

关键修复点 #

1. 反向遍历：从最后一行往前遍历，彻底避免移位后行号错乱的问题
2. 整区域操作：直接复制/清除整段数据，大幅提升处理效率，符合"减少单个单元格修改"的要求
3. 动态更新lastRow：每次移位后同步更新最后行号，确保后续处理范围正确
4. 绑定工作表对象：所有Range操作都指定ws1，避免跨工作表错误
5. 简化逻辑：去掉冗余的Do循环，用反向遍历替代复杂的行号追踪

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