Sub SplitWorksheetByColumn()
    Dim srcSheet As Worksheet
    Dim newSheet As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim splitCol As Integer
    Dim headerRow As Integer
    Dim dict As Object
    Dim key As Variant
    Dim i As Long
    
    ' 设置参数
    Set srcSheet = ThisWorkbook.Worksheets("Sheet1") ' 原始工作表名称
    splitCol = 9 ' 拆分依据列（I列为第9列）
    headerRow = 1 ' 标题行数
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 获取数据范围
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, splitCol).End(xlUp).Row
    lastCol = srcSheet.Cells(headerRow, srcSheet.Columns.Count).End(xlToLeft).Column
    
    ' 创建字典存储唯一值
    Set dict = CreateObject("Scripting.Dictionary")
    For i = headerRow + 1 To lastRow
        If Not dict.exists(srcSheet.Cells(i, splitCol).Value) Then
            dict.Add srcSheet.Cells(i, splitCol).Value, Nothing
        End If
    Next i
    
    ' 遍历每个唯一值创建新表
    For Each key In dict.keys
        ' 删除已存在的工作表
        On Error Resume Next
        ThisWorkbook.Worksheets(key).Delete
        On Error GoTo 0
        
        ' 创建新工作表
        Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        newSheet.Name = key
        
        ' 复制标题
        srcSheet.Rows(headerRow).Copy newSheet.Rows(headerRow)
        
        ' 筛选并复制数据
        srcSheet.Range(srcSheet.Cells(headerRow + 1, 1), srcSheet.Cells(lastRow, lastCol)).AutoFilter _
            Field:=splitCol, _
            Criteria1:=key
            
        srcSheet.UsedRange.Offset(headerRow).SpecialCells(xlCellTypeVisible).Copy _
            newSheet.Cells(headerRow + 1, 1)
            
        srcSheet.AutoFilterMode = False
    Next key
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "拆分完成！共创建 " & dict.Count & " 个工作表。"
End Sub