Sub 分割()
    Dim arr, sht As Worksheet, temp As String, i As Long, k, t, rng1 As Range

    Dim x, xx As String
    Dim x1, x2, y As Integer
   
    x = UCase(InputBox("", "请输入标题列"))
    y = InputBox("", "请输入标题行")
    xx = UCase(InputBox("", "请输入最后一列"))
   
    x1 = Asc(x) - 64
    x2 = Asc(xx) - 64
   
   
    Set rng1 = Range("A1:" & xx & y)
    Dim z As Range
    Set z = Range("" & x & 65536)
   
   
    arr = Range("A" & y + 1 & ":" & x & z.End(xlUp).Row).Value '减去黄色区域
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            temp = arr(i, x1)
            If temp <> "" Then
                If Not .exists(temp) Then
                    .Add temp, Range("a" & i + y).Resize(1, x2)
                Else
                    Set .Item(temp) = Union(.Item(temp), Range("a" & i + y).Resize(1, x2))
                End If
            End If
        Next i
        k = .keys
        t = .Items
        On Error Resume Next
        For i = 0 To .Count - 1
            If Len(Sheets(k(i)).Name) > 0 Then '判断工作表存在
                If Err.Number = 9 Then '如果不存在则添加
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = k(i)
                  
                End If
            End If
            With Sheets(k(i))
                .Cells.Clear
                rng1.Copy .Range("a1") '把表头的前两行也一同复制到新工作表中
                t(i).Copy .Range("a" & y + 1)
               
            End With
        Next
    End With
    Application.ScreenUpdating = True
    MsgBox "处理完毕"
End Sub