Sub Dan()
Dim dataSRow&, strName$
Dim Dic, Dk, strCol
Dim i&, iRow&
Application.DisplayAlerts = 0
'参数调整区域
strCol = "D" '要拆分的字段所在的列号
dataSRow = 2 '非标题行的数据起始行
strName = "数据源" '数据源所在表表名
'代码运行区域
Set Dic = CreateObject("scripting.dictionary")
With Sheets(strName)
iRow = .Cells(.Rows.Count, strCol).End(3).Row
'默认A1为数据起始单元格
For i = dataSRow To iRow Step 1
Dic(CStr(.Cells(i, strCol).Value)) = ""
Next
If Dic.Count = 0 Then
MsgBox "无内容"
Set Dic = Nothing
Exit Sub
End If
Dk = Dic.keys
For i = LBound(Dk) To UBound(Dk)
On Error Resume Next
Sheets(CStr(Dk(i))).Delete
On Error GoTo 0
Sheets(strName).Copy after:=Sheets(strName)
With ActiveSheet
.Name = Dk(i)
iRow = .Cells(.Rows.Count, strCol).End(3).Row
For k = iRow To dataSRow Step -1
If CStr(.Cells(k, strCol).Value) <> CStr(Dk(i)) Then
Cells(k, strCol).EntireRow.Delete
End If
Next
End With
Next
Application.DisplayAlerts = 1
End With
Set Dic = Nothing
MsgBox "拆分完成"
End Sub
