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

"友情提示：

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