Sub cfz()
Dim i&, Myr&, Arr
Dim d, k, t
Set d = CreateObject("scripting.Dictionary")
Myr = Sheet1.[A1048576].End(xlUp).Row
Arr = Sheet1.Range("a1:b" & Myr)
For i = 2 To UBound(Arr)
d(Arr(i, 1)) = d(Arr(i, 1)) + 1
Next
k = d.keys
t = d.items
Sheet2.Activate
[a2].Resize(d.Count, 1) = Application.Transpose(k)
[b2].Resize(d.Count, 1) = Application.Transpose(t)
[a1].Resize(1, 2) = Array("姓名", "重复个数")
Set d = Nothing
End Sub

------------------------------------------------------------------------------------------------------------------

Sub bcfz()
Dim i&, Myr&, Arr
Dim d, k, t, Sht As Worksheet
Set d = CreateObject("Scripting.Dictionary")
For Each Sht In Sheets
If Sht.Name <> "Sheet4" Then
Myr = Sht.[a1048576].End(xlUp).Row
Arr = Sht.Range("a2:a" & Myr)
For i = 1 To UBound(Arr)
d(Arr(i, 1)) = ""
Next
End If
Next
k = d.keys
Sheet4.[a1].Resize(d.Count, 1) = Application.Transpose(k)
Set d = Nothing
End Sub

------------------------------------------------------------------------------------------------------------------

Sub classfication()
Dim w0 As Workbook
Dim w1 As Workbook
Dim sheet1 As Worksheet
Dim r0 As Range
Dim r1 As Range
Dim filename As String
Dim rw()
Dim arr1()
Dim r()
Dim classname
Dim k
Dim i As Long, j As Long
Set classname = CreateObject("Scripting.Dictionary")
Set w0 = ActiveWorkbook
Set sheet1 = w0.Worksheets("总表")
Set r1 = sheet1.UsedRange
Set r0 = r1.Resize(1, r1.Columns.Count)
r = r0
arr1 = r1
'读取分类信息
For i = 2 To UBound(arr1, 1)
k = arr1(i, 1)
classname(k) = classname(k) + 1
Next i
filename = ThisWorkbook.Path & "" & "分表.xlsx"
createbook (filename)
Set w1 = ActiveWorkbook
For Each k In classname.keys
crestesheet w1, k, r
Next k
For i = 2 To UBound(arr1, 1)
rw = r1.Resize(1, r1.Columns.Count).Offset(i - 1, 0)
Set r0 = w1.Worksheets(arr1(i, 1)).UsedRange
r0.Resize(1, r0.Columns.Count).Offset(r0.Rows.Count, 0) = rw
Next i
changetype w1
w1.Close
End Sub
'创建工作薄
Sub createbook(filename As String)
If Dir(filename) = "" Then
Workbooks.Add
Else
Kill filename
Workbooks.Add
End If
ActiveWorkbook.SaveAs filename
End Sub
'创建表
Sub crestesheet(w1 As Workbook, classname, r)
w1.Sheets.Add Worksheets(Worksheets.Count), , 1, xlWorksheet
ActiveSheet.Name = classname
ActiveSheet.Cells(1, 1).Resize(1, UBound(r, 2)) = r
End Sub
'修改表格格式
Sub changetype(w As Workbook)
Dim sheetw As Worksheet, r As Range
For Each sheetw In w.Worksheets
Set r = sheetw.UsedRange
With r
.Borders.LineStyle = xlHairline
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next sheetw
End Sub

------------------------------------------------------------------------------------------------------------------

https://www.jianshu.com/p/9981bbe5c32a

Sub 分类()

Dim i, j As Integer

j = Sheet1.Range("a1048576").End(xlUp).Row

For i = 2 To Sheets.Count

Sheet1.Range("1:" & j).AutoFilter Field:=1, Criteria1:=Sheets(i).Name

Sheet1.Range("1:" & j).copy Sheets(i).Range("a1")

Next

End Sub