如何将Excel中A列含Presenters的行移至指定命名区域下方？

问题描述 #

工作表A列包含多种"RallyType"值，需将A列中包含"Presenter"的行移动到名为Presenter_RallyType_Section的指定区域下方，现有宏仅能将行移至工作表末尾，需调整逻辑实现目标。

修改后的VBA代码 #

Option Explicit

Sub PresentersMOVESheet()
    Dim ws As Worksheet
    Dim lr As Long
    Dim r As Long
    Dim targetSection As Range
    Dim insertRow As Long
    
    Application.ScreenUpdating = False
    
    ' 指定目标工作表（无需重复定义两个相同工作表）
    Set ws = Sheets("Registration Sheet orig")
    
    ' 获取指定命名区域，同时捕获区域不存在的错误
    On Error Resume Next
    Set targetSection = ws.Range("Presenter_RallyType_Section")
    On Error GoTo 0
    
    ' 检查命名区域是否存在，避免后续逻辑报错
    If targetSection Is Nothing Then
        MsgBox "命名区域Presenter_RallyType_Section不存在，请检查！", vbExclamation
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 计算命名区域下方的起始插入行
    insertRow = targetSection.Row + targetSection.Rows.Count
    
    ' 获取A列最后一行数据行号
    lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
    
    ' 从第一行开始循环检查
    r = 1
    Do
        ' 判断当前行A列是否包含"Presenter"
        If InStr(ws.Cells(r, "A"), "Presenter") > 0 Then
            ' 将目标行复制到指定区域下方的当前插入行
            ws.Rows(r).Copy ws.Cells(insertRow, "A")
            ' 删除原行
            ws.Rows(r).Delete
            ' 最后一行行号减1（因为删除了一行）
            lr = lr - 1
            ' 插入行号加1（下一行要放在刚插入行的下方）
            insertRow = insertRow + 1
        Else
            ' 不满足条件则检查下一行
            r = r + 1
        End If
    Loop Until r > lr
    
    Application.ScreenUpdating = True
    ws.Activate
    MsgBox "Presenter行移动完成！"
End Sub

关键修改说明 #

• 简化变量定义：原代码中ws1和ws2指向同一工作表，合并为单个变量ws，减少冗余。
• 增加区域校验：添加错误捕获逻辑，检查指定命名区域是否存在，避免因区域不存在导致宏崩溃。
• 动态锁定插入位置：通过targetSection.Row + targetSection.Rows.Count获取命名区域下方的第一行作为初始插入点，每次插入后将insertRow加1，确保后续行依次追加在已移动行的下方。
• 保留原有循环逻辑：维持原循环中删除行后调整lr的逻辑，避免遗漏数据行。

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