Excel执行VBA批量拆分用户数据时卡顿且最后一个子过程失效求助

问题1：执行Main宏时Excel冻结 #

原因 #

1. 低效的单元格遍历：每个子过程都遍历UsedRange所有单元格查找起始位置，数据量大时耗时极长；
2. 不必要的工作表激活：频繁调用Activate增加Excel的UI渲染开销；
3. 未关闭屏幕更新：每次创建工作表、复制数据都会触发屏幕刷新，拖慢执行速度；
4. 未明确绑定工作表：Range对象未指定所属工作表，可能因活动工作表切换导致引用错误。

修复方案 #

• 执行宏前关闭屏幕更新与事件触发，执行后恢复；
• 使用Find方法替代全单元格遍历，大幅提升查找效率；
• 所有Range对象明确绑定到Data工作表，避免依赖活动工作表；
• 移除不必要的Activate调用。

问题2：SelectRangeUser8无法正常工作 #

原因 #

1. 未终止查找循环：找到"Total"后未执行Exit For，会继续遍历后续单元格，可能覆盖正确的endCell；
2. 边界未校验：currentCell.Offset(-2)未判断行号有效性，若"Total"在第1/2行会直接报错；
3. 起始单元格逻辑错误：代码中startCell取第一个"User8"，但结合业务逻辑，应取最后一个"User8"作为数据起始位置，否则会包含冗余数据。

修复方案 #

• 找到"Total"后立即退出循环；
• 校验Offset(-2)的行号是否在有效范围内；
• 将startCell设置为最后一个"User8"的位置，确保数据范围准确。

完整修复后的代码 #

优化后的Main宏 #

Sub Main()
    ' 关闭屏幕更新与事件，提升执行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 调用通用处理过程，避免重复代码
    ProcessUserData "User1", "User2"
    ProcessUserData "User2", "User3"
    ProcessUserData "User3", "User4"
    ProcessUserData "User4", "User5"
    ProcessUserData "User5", "User6"
    ProcessUserData "User6", "User7"
    ProcessUserDataSpecial "User7", "User8", 2 ' 处理第2次出现的User7
    ProcessUserDataLast "User8", "Total" ' 处理以Total结尾的User8
    
    ' 恢复设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

通用用户数据处理子过程 #

' 处理普通用户：从startUser开始，到endUser结束
Sub ProcessUserData(startUser As String, endUser As String)
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Data")
    
    Dim startCell As Range
    Dim endCell As Range
    
    ' 查找起始位置
    Set startCell = wsData.UsedRange.Find(What:=startUser, LookIn:=xlValues, LookAt:=xlWhole)
    If startCell Is Nothing Then Exit Sub
    
    ' 查找结束位置
    Set endCell = wsData.Range(startCell, wsData.Cells.SpecialCells(xlCellTypeLastCell)).Find(What:=endUser, LookIn:=xlValues, LookAt:=xlWhole)
    If endCell Is Nothing Then Exit Sub
    
    ' 校验偏移后的行有效性
    If endCell.Row - 2 < 1 Then Exit Sub
    Set endCell = endCell.Offset(-2)
    
    ' 创建新工作表并复制数据（处理已存在的情况）
    Dim wsNew As Worksheet
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets(startUser)
    On Error GoTo 0
    If wsNew Is Nothing Then
        Set wsNew = ThisWorkbook.Worksheets.Add
        wsNew.Name = startUser
    End If
    
    ' 复制指定列范围（A-K共11列）
    wsData.Range(startCell, endCell).Resize(, 11).Copy wsNew.Range("A1")
    ' 命名数据范围
    wsNew.Range("A1").CurrentRegion.Name = startUser
End Sub

' 处理需要指定出现次数的用户（比如User7是第2次出现）
Sub ProcessUserDataSpecial(startUser As String, endUser As String, occurrence As Integer)
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Data")
    
    Dim startCell As Range
    Dim endCell As Range
    Dim findCount As Integer
    Dim foundCell As Range
    
    findCount = 0
    Set foundCell = wsData.UsedRange.Find(What:=startUser, LookIn:=xlValues, LookAt:=xlWhole)
    
    ' 循环查找直到找到指定次数的起始位置
    Do While Not foundCell Is Nothing
        findCount = findCount + 1
        If findCount = occurrence Then
            Set startCell = foundCell
            Exit Do
        End If
        Set foundCell = wsData.UsedRange.FindNext(foundCell)
    Loop
    
    If startCell Is Nothing Then Exit Sub
    
    ' 查找结束位置
    Set endCell = wsData.Range(startCell, wsData.Cells.SpecialCells(xlCellTypeLastCell)).Find(What:=endUser, LookIn:=xlValues, LookAt:=xlWhole)
    If endCell Is Nothing Then Exit Sub
    
    If endCell.Row - 2 < 1 Then Exit Sub
    Set endCell = endCell.Offset(-2)
    
    ' 创建新工作表并复制数据
    Dim wsNew As Worksheet
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets(startUser)
    On Error GoTo 0
    If wsNew Is Nothing Then
        Set wsNew = ThisWorkbook.Worksheets.Add
        wsNew.Name = startUser
    End If
    
    wsData.Range(startCell, endCell).Resize(, 11).Copy wsNew.Range("A1")
    wsNew.Range("A1").CurrentRegion.Name = startUser
End Sub

' 处理以Total结尾的最后一个用户（User8）
Sub ProcessUserDataLast(startUser As String, endMarker As String)
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Data")
    
    Dim startCell As Range
    Dim endCell As Range
    Dim foundCell As Range
    
    ' 查找最后一个出现的startUser
    Set foundCell = wsData.UsedRange.Find(What:=startUser, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious)
    If foundCell Is Nothing Then Exit Sub
    Set startCell = foundCell
    
    ' 查找Total标记
    Set endCell = wsData.Range(startCell, wsData.Cells.SpecialCells(xlCellTypeLastCell)).Find(What:=endMarker, LookIn:=xlValues, LookAt:=xlWhole)
    If endCell Is Nothing Then Exit Sub
    
    ' 校验偏移行有效性（确保endCell在startCell之后）
    If endCell.Row - 2 < startCell.Row Then Exit Sub
    Set endCell = endCell.Offset(-2)
    
    ' 创建新工作表并复制数据
    Dim wsNew As Worksheet
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets(startUser)
    On Error GoTo 0
    If wsNew Is Nothing Then
        Set wsNew = ThisWorkbook.Worksheets.Add
        wsNew.Name = startUser
    End If
    
    wsData.Range(startCell, endCell).Resize(, 11).Copy wsNew.Range("A1")
    wsNew.Range("A1").CurrentRegion.Name = startUser
End Sub

关键优化点说明 #

1. 通用化代码：将重复的用户处理逻辑封装为3个通用子过程，减少代码冗余，便于后续维护；
2. 高效查找：使用Find和FindNext替代全单元格遍历，查找速度提升数倍；
3. 错误处理：添加工作表已存在的判断，避免创建重复工作表报错；
4. 边界校验：增加行号有效性判断，防止因数据位置异常导致的运行时错误；
5. 性能提升：关闭屏幕更新和事件触发，避免不必要的UI刷新。

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