"功能：用當前工作薄每條記錄建立一個新的工作薄，每個新建工作薄以第一行為標題行，第二行為記錄，以A列記錄為工作薄名稱自動儲存。

"友情提示：

SubSplitExl()

Application.DisplayAlerts=False"新建的文件存在時，不傳送警示，覆蓋式儲存

DimlngRs&,lngCs&,cx&,strEndCl$

DimtopR(),EveryR(),oExlAsObject,oWkAsWorkbook

DimstrPath$

strPath=ThisWorkbook.Path&"\"

WithActiveSheet.UsedRange

lngRs=.Rows.Count

lngCs=.Columns.Count

EndWith

strEndCl=Replace(Replace(Cells(1,lngCs).Address,"$",""),"1","")

topR=Range("A1:"&strEndCl&"1")"資料標題行

Forcx=2TolngRs

EveryR=Range("A"&Format(cx)&":"&strEndCl&Format(cx))"把每行記錄放入陣列

SetoWk=Application.Workbooks.Add

WithoWk

".Parent.Visible=True

With.Sheets(1)

.Range("A1:"&strEndCl&"1")=topR"把標題行放入另建的工作薄

.Range("A2:"&strEndCl&"2")=EveryR"把單個記錄放入同一另建的工作薄

EndWith

.SaveAsFilename:=strPath&EveryR(1,1)&".xls""以每行A列記錄為工作薄名稱

.Close

EndWith

Next

SetoWk=Nothing

SetoExl=Nothing

ErasetopR:EraseEveryR

Application.DisplayAlerts=True

EndSub