Sub 列数据转文件()
Dim Twork As Workbook, Tsht As Worksheet, nameDic, EndRow As Long
Application.ScreenUpdating = False
Set nameDic = CreateObject("Scripting.Dictionary")
EndRow = [A65536].End(xlUp).Row'获取A列末行,根据实际修改为某列
For Each rng In Range("A2:A" & EndRow)
'遍历A列第二行开始的所有关键字,如非A列,请将A修改成其它列
nameDic(rng.Value) = "" '将关键字添加至字典对象中（不会重复）
Next
If ActiveSheet.AutoFilterMode = False Then Range("A1:C1").AutoFilter
'将工作表A1:C1区域设置为自动筛选,按自己需要修改区域
For Each t In nameDic.keys'遍历字典中所有的关键字
If t <> "" Then
ActiveSheet.Range("$A$1:$C$" & EndRow).AutoFilter Field:=1, Criteria1:=t
'从自动筛选中筛选值为变量t的所有区域
Set Twork = Workbooks.Add: Set Tsht = Twork.Sheets(1)
'新建工作簿twork对象,设置Tsht工作表对象
Range("A1").CurrentRegion.Copy Tsht.Range("A1")
'将自动筛选出的所有结果复制到新的工作薄中
Twork.SaveAs t: Twork.Close: Set Tsht = Nothing: Set Twork = Nothing
另存新的工作簿,名字为变量t(既A列中的关键字),然后关闭工作簿,清空对象变量
End If
Next
Application.ScreenUpdating = True
End Sub
