将数据表D列中的各名字筛选出来作为新表的名字并复制其内容

Sub wan()

Dim sht As Worksheet
Dim i, j, k As Integer

'开始前先清空各表'
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht In Sheets
        If sht.Name <> 数据 Then
            sht.Delete
        End If
    Next
End If
Application.DisplayAlerts = True

'利用D列中的部门名字新建各表'
For i = 2 To Sheet1.Range("a65536").End(xlUp).Row
    k = 0
    
    For Each sht In Sheets
        If sht.Name = Sheet1.Range("d" & i) Then
            k = 1
        End If
    Next
    
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Range("d" & i)
    End If
        
Next

'利用筛选将各内容放入对应表'
For j = 2 To Sheets.Count
    Sheet1.Range("a1:f10000").AutoFilter field:=4, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f10000").Copy Sheets(j).Range("a1")
Next

End Sub

对上述的修改，上述需要手动指定筛选的列，在此作出自动选择

引入两个新语法
①Inputbox 接受键盘输入的内容
②MsgBox 输出指定内容

Sub t()

Dim sht As Worksheet
Dim k, i, j As Integer
Dim irow As Integer
Dim l As Integer


l = InputBox("请输入你要按哪列分")


'删除无意义的表'
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
    For Each sht1 In Sheets
        If sht1.Name <> "数据" Then
            sht1.Delete
        End If
    Next
End If
Application.DisplayAlerts = True

irow = Sheet1.Range("a65536").End(xlUp).Row
'拆分表'
For i = 2 To irow
    k = 0
    For Each sht In Sheets
        If sht.Name = Sheet1.Cells(i, l) Then
            k = 1
        End If
    Next
    
    
    If k = 0 Then
        Sheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
    End If

Next
'拷贝数据'

For j = 2 To Sheets.Count
    Sheet1.Range("a1:f" & irow).AutoFilter Field:=l, Criteria1:=Sheets(j).Name
    Sheet1.Range("a1:f" & irow).Copy Sheets(j).Range("a1")
Next

MsgBox "已处理完毕"

End Sub