如何在VBA代码中按U列唯一姓名逐行拆分数据？

以下是修改后的VBA代码，实现自动识别U列唯一姓名、拆分对应数据为连续行，并完整保留原有优先级排序及日期公式功能：

Public Sub SortPrioritiesByUniqueName()

Dim priorityBlocks() As Variant ' 改为动态数组适配大型项目
Dim p As Variant
Dim l As Variant
Dim thisRow As Long
Dim nextRow As Long
Dim blockCount As Long
Dim i As Long, j As Long
Dim swapped As Boolean
Dim uniqueNames As Object
Dim namesArr As Variant
Dim nameVal As String
Dim lastRow As Long
Dim targetRow As Long

' 关闭屏幕更新提升大型项目处理效率
Application.ScreenUpdating = False
Application.EnableEvents = False

' --- 自动获取U列唯一姓名（字典去重，兼容所有Excel版本）---
Set uniqueNames = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "U").End(xlUp).Row

' 遍历数据行（从第4行开始，与原代码逻辑一致）
For i = 4 To lastRow
    nameVal = Trim(Cells(i, "U").Value)
    If nameVal <> "" Then
        uniqueNames(nameVal) = True ' 字典自动忽略重复值
    End If
Next i

' 将唯一姓名转为数组
namesArr = uniqueNames.Keys

' --- 按唯一姓名重新组织数据行，同一姓名行连续排列 ---
' 在数据末尾插入标记行界定范围
targetRow = Cells(Rows.Count, "S").End(xlUp).Row + 2
Cells(targetRow, "A").Value = "@"

' 遍历每个唯一姓名，移动对应行到目标区域
For j = LBound(namesArr) To UBound(namesArr)
    thisRow = 4
    Do While Cells(thisRow, "A").Value <> "@"
        If Trim(Cells(thisRow, "U").Value) = namesArr(j) Then
            ' 剪切当前行并插入到姓名分组区域
            Rows(thisRow).Cut
            Rows(targetRow).Insert Shift:=xlShiftDown
            targetRow = targetRow + 1
        Else
            thisRow = thisRow + 1
        End If
    Loop
    ' 更新标记行位置，避免重复处理
    targetRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Cells(targetRow, "A").Value = "@"
Next j

' 清理标记行
Cells(Rows.Count, "A").End(xlUp).ClearContents

' --- 保留原有优先级排序及日期公式逻辑 ---
' 重新获取数据最后一行
nextRow = Cells(Rows.Count, "S").End(xlUp).Row

' 插入新的标记行用于块识别
Cells(nextRow + 2, "A").Value = "@"

' 识别所有优先级块
thisRow = 4
blockCount = 0
Do While Cells(thisRow, "A").Value <> "@"
    ' 动态扩展数组大小，避免大型项目溢出
    ReDim Preserve priorityBlocks(blockCount, 2)
    priorityBlocks(blockCount, 0) = Cells(thisRow, "A").Value
    priorityBlocks(blockCount, 1) = thisRow
    nextRow = Cells(thisRow, "A").End(xlDown).Row
    priorityBlocks(blockCount, 2) = nextRow - thisRow
    thisRow = nextRow
    blockCount = blockCount + 1
Loop
    
' 冒泡排序优先级块
Do
    swapped = False
    For i = 1 To blockCount - 1
        If priorityBlocks(i - 1, 0) > priorityBlocks(i, 0) Then
            swapped = True
            
            ' 日期公式设置逻辑（保留原修改）
            If Cells(priorityBlocks(i, 1), "A").Value = "1" Then
                Cells(priorityBlocks(i, 1), "AB") = "=(ACTUALSTARTDATE + (INDIRECT(ADDRESS(ROW(),17))/8))"
                Cells(priorityBlocks(i, 1), "AC") = "=(INDIRECT(ADDRESS(ROW(),17))/8)+(INDIRECT(ADDRESS(ROW(),28)))"
                Cells(priorityBlocks(i, 1), "AC").Name = "ENDDATE" & Cells(priorityBlocks(i, 1), "A").Value
            End If
            
            ' 移动优先级块行
            Cells(priorityBlocks(i, 1), "A").Resize(priorityBlocks(i, 2), 1).EntireRow.Cut
            Cells(priorityBlocks(i - 1, 1), "A").EntireRow.Insert xlShiftDown
            
            ' 更新块数组数据
            p = priorityBlocks(i - 1, 0)
            l = priorityBlocks(i - 1, 2)
            priorityBlocks(i - 1, 0) = priorityBlocks(i, 0)
            priorityBlocks(i - 1, 2) = priorityBlocks(i, 2)
            priorityBlocks(i, 0) = p
            priorityBlocks(i, 1) = priorityBlocks(i - 1, 1) + priorityBlocks(i - 1, 2)
            priorityBlocks(i, 2) = l
        End If
    Next i
    DoEvents
Loop Until swapped = False

' 清理标记行
Cells(Rows.Count, "A").End(xlUp).ClearContents

' 批量设置日期公式（保留原修改）
For i = 1 To blockCount - 1
        If Cells(priorityBlocks(i, 1), "A").Value = "1" Then
            Cells(priorityBlocks(i, 1), "AB") = "=(ACTUALSTARTDATE + (INDIRECT(ADDRESS(ROW(),17))/8))"
            Cells(priorityBlocks(i, 1), "AC") = "=(INDIRECT(ADDRESS(ROW(),17))/8)+(INDIRECT(ADDRESS(ROW(),28)))"
            Cells(priorityBlocks(i, 1), "AC").Name = "ENDDATE" & Cells(priorityBlocks(i, 1), "A").Value
        Else
            Cells(priorityBlocks(i, 1), "AC").Name = "ENDDATE" & Cells(priorityBlocks(i, 1), "A").Value
            Cells(priorityBlocks(i, 1), "AB") = "=(ENDDATE" & Cells(priorityBlocks(i, 1), "A").Value - 1 & " + (INDIRECT(ADDRESS(ROW(),17))/8))"
        End If
Next i

' 恢复屏幕更新与事件
Application.ScreenUpdating = True
Application.EnableEvents = True

Range("A2").Select

End Sub

关键修改说明 #

1. 自动去重获取唯一姓名

   • 使用Scripting.Dictionary实现跨版本兼容的姓名去重，无需预设列表
   • 若使用Excel 365/2021+，可替换为UNIQUE函数：

     namesArr = Application.WorksheetFunction.Unique(Range("U4:U" & lastRow))
     

2. 适配大型项目优化

   • 将固定大小的priorityBlocks数组改为动态数组，避免数据量过大时溢出
   • 添加屏幕更新与事件禁用逻辑，提升大型数据集处理速度

3. 完整保留原有功能

   • 姓名分组完成后，直接执行原有的优先级排序、日期公式设置逻辑，确保业务流程不中断

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