如何基于Excel J列唯一值动态创建工作表并自动复制对应行数据

以下代码可直接基于J列部门字段自动创建对应工作表，已存在的工作表会直接复用不会报错，同时优化了原有代码的运行效率：

Sub CopyRowsAutoCreateSheet()
    Dim sourceWs As Worksheet
    Dim targetWs As Worksheet
    Dim bottomJ As Long
    Dim c As Range
    Dim sheetExist As Boolean
    
    ' 绑定数据源工作表
    Set sourceWs = ThisWorkbook.Sheets("All Dept.")
    ' 获取J列最后一行行号，使用Long类型避免行数超过Integer上限报错
    bottomJ = sourceWs.Range("J" & sourceWs.Rows.Count).End(xlUp).Row
    
    ' 遍历J列所有部门单元格
    For Each c In sourceWs.Range("J2:J" & bottomJ)
        ' 跳过空值避免创建无效工作表
        If c.Value <> "" Then
            sheetExist = False
            ' 校验对应部门工作表是否已存在
            For Each targetWs In ThisWorkbook.Sheets
                If targetWs.Name = CStr(c.Value) Then
                    sheetExist = True
                    Exit For
                End If
            Next targetWs
            
            ' 工作表不存在时自动新建
            If Not sheetExist Then
                Set targetWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                targetWs.Name = CStr(c.Value)
                ' 下方代码为新表自动复制表头，不需要可直接删除
                sourceWs.Rows(1).Copy targetWs.Range("A1")
            End If
            
            ' 复制当前行到对应工作表末尾
            c.EntireRow.Copy targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next c
    
    ' 释放对象内存
    Set sourceWs = Nothing
    Set targetWs = Nothing
    MsgBox "所有数据已分配完成", vbInformation
End Sub

代码特性说明 #

• 新增工作表存在性校验逻辑，遇到已创建的部门工作表直接复用，不会触发重复创建报错
• 移除了不必要的工作表激活操作，运行时不会出现屏幕闪跳，执行效率更高
• 新增空值跳过逻辑，避免J列空单元格生成无效工作表
• 内置可选的表头自动复制功能，新建的部门工作表会自动同步第一行表头
• 行号使用Long类型存储，支持超过32767行的大数据量场景，不会出现溢出报错

注意事项 #

如果J列的部门名称包含\ / ? * [ ]等Excel工作表命名禁止字符，请先清理对应内容后再运行宏，避免创建工作表时触发命名规则报错

参考示例数据 #

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