Excel VBA代码无法按需求重排指定区域行的问题求助

现有一段VBA代码用于移动行，但无法按预期完成重排操作：

需求目标 #

对Excel工作表中以灰色行开头、蓝色行结尾的区域进行行重排：将区域内最后一行移至首位，依次倒序排列；仅处理非空行，完成当前区域后继续处理下一个区域。

当前问题 #

• 区域识别存在偏差，重排时会覆盖或包含空行；移除首个空区域后代码完全失效。
• 在弹窗选择「否」后，无法识别下一个目标区域。

工作表结构示例 #

工作表中存在多个连续区域，每个区域以灰色背景行起始，蓝色背景行结束，区域内包含不同背景色的非空行。

现有代码 #

Sub ReorderSection()

    ' Define variables
    Dim ws As Worksheet
    Dim firstRow As Long, lastRow As Long
    Dim cellValue As String
    Dim tempRange As Range, cell As Range
    Dim i As Long
    
    ' Set the worksheet to be processed
    Set ws = srcSht = ThisWorkbook.Worksheets("Sheet1")
    
    ' Find the first row with gray color
    For firstRow = 1 To ws.UsedRange.Rows.Count
        If ws.Cells(firstRow, 1).Interior.Color = 13158600 Then
            Exit For
        End If
    Next firstRow
    
    ' If no gray row found, exit the sub
    If firstRow = ws.UsedRange.Rows.Count Then
        MsgBox "No section found!", vbExclamation
        Exit Sub
    End If
    
    ' Find the last row with blue color
    For lastRow = ws.UsedRange.Rows.Count To 1 Step -1
        If ws.Cells(lastRow, 1).Interior.Color = 15773696 Then
            Exit For
        End If
    Next lastRow
    
    ' If no blue row found, exit the sub
    If lastRow = 1 Then
        MsgBox "No section found!", vbExclamation
        Exit Sub
    End If
    
    ' Are these the start and end rows
    Dim result As Integer
    result = MsgBox("Reorder rows " & firstRow & " to " & lastRow & "?", vbYesNo)
    
    ' If yes, reorder the rows
    If result = vbYes Then
        'temp range of section data
        Set tempRange = ws.Range("A" & firstRow, "Z" & lastRow)
        
        ' Loop through rows in reverse order and place them at the beginning
        For i = lastRow - 1 To firstRow Step 1
            Set cell = tempRange.Rows(i)
            cell.Cut Destination:=ws.Rows(firstRow)
            firstRow = firstRow + 1
        Next i
        
        ' message reordered
        MsgBox "Section reordered successfully!", vbInformation
    End If
    
End Sub

工作表数据示例 #

修复后的代码及说明 #

核心改进点 #

1. 区域识别逻辑优化：从当前位置向下查找连续的「灰→蓝」区间，跳过空行，避免跨区域识别错误；
2. 循环处理所有区域：添加外层循环，处理完一个区域后自动定位下一个灰色起始行；
3. 空行过滤：重排时仅收集非空行，彻底排除空行干扰；
4. 「否」分支处理：选择不重排当前区域时，直接跳转到结束行之后，继续识别下一个区域。

修复代码 #

Sub ReorderAllSections()
    Dim ws As Worksheet
    Dim currentRow As Long, sectionStart As Long, sectionEnd As Long
    Dim lastUsedRow As Long
    Dim result As Integer
    Dim tempRows As Collection
    Dim rng As Range, row As Range
    
    ' 设置目标工作表
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastUsedRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    currentRow = 1
    
    ' 定义颜色常量（需与实际工作表颜色匹配）
    Const GRAY_COLOR As Long = 13158600
    Const BLUE_COLOR As Long = 15773696
    
    ' 循环处理所有区域
    Do While currentRow <= lastUsedRow
        ' 查找下一个灰色起始行，跳过空行
        Do While currentRow <= lastUsedRow
            If ws.Cells(currentRow, 1).Interior.Color = GRAY_COLOR And _
               Trim(ws.Cells(currentRow, 1).Value) <> "" Then
                sectionStart = currentRow
                Exit Do
            End If
            currentRow = currentRow + 1
        Loop
        
        ' 未找到起始行则退出循环
        If currentRow > lastUsedRow Then Exit Do
        
        ' 查找当前区域对应的蓝色结束行（仅在起始行之后查找）
        sectionEnd = 0
        For currentRow = sectionStart + 1 To lastUsedRow
            If ws.Cells(currentRow, 1).Interior.Color = BLUE_COLOR And _
               Trim(ws.Cells(currentRow, 1).Value) <> "" Then
                sectionEnd = currentRow
                Exit For
            End If
        Next currentRow
        
        ' 未找到对应结束行，提示后跳过
        If sectionEnd = 0 Then
            MsgBox "区域起始行" & sectionStart & "未找到对应的蓝色结束行，跳过该区域", vbExclamation
            currentRow = sectionStart + 1
            GoTo ContinueLoop
        End If
        
        ' 询问是否重排当前区域
        result = MsgBox("是否重排区域：行" & sectionStart & " 至 行" & sectionEnd & "?", vbYesNo)
        
        If result = vbYes Then
            ' 收集区域内非空行（倒序）
            Set tempRows = New Collection
            For currentRow = sectionEnd To sectionStart Step -1
                If Trim(ws.Cells(currentRow, 1).Value) <> "" Then
                    tempRows.Add ws.Rows(currentRow).EntireRow
                End If
            Next currentRow
            
            ' 删除原区域非空行
            For Each rng In tempRows
                rng.Delete
            Next rng
            
            ' 插入倒序后的行到原起始位置
            sectionStart = ws.Cells(sectionStart, 1).End(xlUp).Row + 1
            For Each row In tempRows
                row.Copy Destination:=ws.Rows(sectionStart)
                sectionStart = sectionStart + 1
            Next row
            
            MsgBox "当前区域重排完成！", vbInformation
            ' 更新最后使用行（因行有插入删除）
            lastUsedRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            currentRow = sectionStart
        Else
            ' 选择不重排，直接跳转到结束行之后
            currentRow = sectionEnd + 1
        End If
        
ContinueLoop:
    Loop
    
    MsgBox "所有区域处理完成！", vbInformation
End Sub

使用说明 #

• 代码中GRAY_COLOR和BLUE_COLOR需与实际工作表中的颜色值匹配，若颜色不符可通过MsgBox(ws.Cells(目标行,1).Interior.Color)获取对应颜色值替换；
• 重排逻辑：收集区域内所有非空行→倒序→删除原行→插入到原起始位置；
• 自动跳过空行，处理完一个区域后自动寻找下一个「灰→蓝」区域，选择「否」时直接跳过当前区域继续处理。

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