'功能:用当前工作薄每条记录创建一个新的工作薄,每个新建工作薄以第一行为标题行,第二行为记录,以A列记录为工作薄名称自动保存。
'友情提示:
1、如何把下面的代码添加到VBA环境:点击“开发工具”-“visual Basic”进入vba编辑环境,在左侧的“工程”树里点击鼠标右键,选择“插入”-“模块”,然后把下面的代码粘贴到右侧的编辑区里。
2、如何使用:可创建热键调用,也可点击“开发工具”-“visual Basic”进入vba编辑环境,在该过程代码里点击一下,然后点击工具栏上的运行按钮(是一个实心三角形,鼠标放上去停留一会,有提示“运行子过程/...”)。
Sub SplitExl()
Application.DisplayAlerts = False '新建的文档存在时,不发送警示,覆盖式保存
Dim lngRs&, lngCs&, cx&, strEndCl$
Dim topR(), EveryR(), oExl As Object, oWk As Workbook
Dim strPath$
strPath = ThisWorkbook.Path & "\"
With ActiveSheet.UsedRange
lngRs = .Rows.Count
lngCs = .Columns.Count
End With
strEndCl = Replace(Replace(Cells(1, lngCs).Address, "$", ""), "1", "")
topR = Range("A1:" & strEndCl & "1") '数据标题行
For cx = 2 To lngRs
EveryR = Range("A" & Format(cx) & ":" & strEndCl & Format(cx)) '把每行记录放入数组
Set oWk = Application.Workbooks.Add
With oWk
'.Parent.Visible = True
With .Sheets(1)
.Range("A1:" & strEndCl & "1") = topR '把标题行放入另建的工作薄
.Range("A2:" & strEndCl & "2") = EveryR '把单个记录放入同一另建的工作薄
End With
.SaveAs Filename:=strPath & EveryR(1, 1) & ".xls" '以每行A列记录为工作薄名称
.Close
End With
Next
Set oWk = Nothing
Set oExl = Nothing
Erase topR: Erase EveryR
Application.DisplayAlerts = True
End Sub
在菜单栏找数据--筛选--自动筛选
用宏真快,可以自己写一个。