Excel VBA实现按B列员工姓名拆分记录到对应命名工作表

你原有代码仅实现了将RawData表非空行的C-F列数据写入DiscrepencyForm表的固定区域，未包含员工名去重、独立工作表创建、匹配数据写入的逻辑，无法满足分表需求。

实现逻辑 #

• 读取RawData表全量有效数据，通过字典提取B列不重复的员工姓名，避免重复建表
• 逐个校验员工名对应工作表是否存在：不存在则新建并复制表头，存在则清空历史旧数据避免重复
• 遍历原始数据，将每个员工对应的所有记录写入其专属命名工作表
• 运行全程关闭屏幕刷新、自动计算等非必要功能提升运行速度，执行完成后恢复Excel默认设置

可用代码 #

Sub SplitDataByEmployee()
    Const RAW_SHEET_NAME As String = "RawData"
    Const START_ROW As Long = 2 ' 数据起始行，第1行默认为表头
    Dim lastRow As Long, lastCol As Long, i As Long
    Dim empName As String
    Dim rawSht As Worksheet, empSht As Worksheet
    Dim empDict As Object
    Dim dataArr As Variant
    
    ' 关闭非必要功能提速
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
    Set rawSht = ThisWorkbook.Worksheets(RAW_SHEET_NAME)
    Set empDict = CreateObject("Scripting.Dictionary")
    
    ' 获取原始数据边界
    lastRow = rawSht.Cells(rawSht.Rows.Count, "B").End(xlUp).Row
    lastCol = rawSht.Cells(1, rawSht.Columns.Count).End(xlToLeft).Column
    ' 全量数据读入数组，减少单元格操作提升效率
    dataArr = rawSht.Range("A1", rawSht.Cells(lastRow, lastCol)).Value
    
    ' 收集B列所有不重复员工姓名
    For i = START_ROW To lastRow
        empName = Trim(dataArr(i, 2))
        If empName <> "" And Not empDict.Exists(empName) Then
            empDict.Add empName, ""
        End If
    Next i
    
    ' 逐个生成/更新员工工作表
    For Each empName In empDict.Keys
        ' 校验工作表是否存在
        On Error Resume Next
        Set empSht = ThisWorkbook.Worksheets(empName)
        On Error GoTo 0
        If empSht Is Nothing Then
            ' 新建工作表放在所有表末尾
            Set empSht = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            empSht.Name = empName
            ' 复制表头
            rawSht.Rows(1).Copy Destination:=empSht.Rows(1)
        Else
            ' 清空已有表的旧数据，保留表头
            empSht.Rows(START_ROW & ":" & empSht.Rows.Count).Clear
        End If
        
        ' 写入当前员工的所有记录
        Dim writeRow As Long: writeRow = START_ROW
        For i = START_ROW To lastRow
            If Trim(dataArr(i, 2)) = empName Then
                empSht.Range(empSht.Cells(writeRow, 1), empSht.Cells(writeRow, lastCol)).Value = _
                    Application.Index(dataArr, i, 0)
                writeRow = writeRow + 1
            End If
        Next i
        
        ' 自动调整列宽适配内容
        empSht.Columns.AutoFit
        Set empSht = Nothing
    Next empName
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    
    MsgBox "拆分完成，共生成" & empDict.Count & "个员工专属工作表", vbInformation
End Sub

使用说明 #

• 若原始数据表名称不是RawData，修改代码开头RAW_SHEET_NAME常量的取值即可
• 若数据不是从第2行开始（即表头不在第1行），对应修改START_ROW常量取值
• 代码自动对员工姓名做前后空格去除处理，避免因空格差异导致同个员工被拆分为多个工作表
• 重复运行代码会自动覆盖员工工作表内的旧数据，不会出现重复追加的问题

附示例数据表结构：

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