以下為通用模板，可以透過選擇任意拆分電子表格為WORD格式
思路如下：
1.選擇要拆分的電子表格
2.新建WORD物件
3.在WORD中插入表格數量
4.透過迴圈，將電子表格內容插入每個WORD表格
5.儲存退出
Sub 批次拆分表格為WORD格式（）
Dim tim1 As Date， tim2 As Date： tim1 = Timer
Application。DisplayAlerts = False ‘禁用警告提示
Dim arr， d As Object， sh As Worksheet
Set d = CreateObject（“scripting。dictionary”）
filename = Application。GetOpenFilename（“Excel 檔案 （*。xls*），*。xls*”， ， “請選擇要分表的工作表所在的位置004！”， ， 0）
If filename = False Then Exit Sub
Set sjwk = Workbooks。Open（filename） ’要分表的資料所在表
‘arr = sjwk。ActiveSheet。Cells ’快速選擇一個工作表的所有區域#################################################*****************************************************************************************************************************************************************************************************
Set rng1 = Application。InputBox（“請選擇工作表準備參加拆分的完整區域，不要選擇整列整行，只選擇絕對區域”， “選取提示”， ， ， ， ， ， 8）
If rng1 Is Nothing Then MsgBox “您沒有選擇要儲存的列區域”： Exit Sub
arr = sjwk。ActiveSheet。Range（rng1。Address）
shname = sjwk。ActiveSheet。Name
‘y = sjwk。ActiveSheet。Range（“a1”）。CurrentRegion。Columns。Count
y = UBound（arr， 2）
bh = Application。InputBox（“請輸入標題的行數【如標題為1行，則寫1，2行則寫2】：”， “提示”， ， ， ， ， ， 1）
ls = Application。InputBox（“請輸入要分表的關鍵字所在列數【A列填寫1，B列填寫2，如此類推】：”， “提示”， ， ， ， ， ， 1）
lsz = ChgNumToABC（ls）
zdl = ChgNumToABC（UBound（arr， 2））
For i = 1 To UBound（arr）
If d。Exists（arr（i， ls）） Then
Set d（arr（i， ls）） = Union（d（arr（i， ls））， Rows（i））
Else
Set d（arr（i， ls）） = Union（Rows（“1：” & bh）， Rows（i））
End If
Next i
X = d。keys
If Dir（ThisWorkbook。path & “\拆分文件”， 16） = “” Then MkDir ThisWorkbook。path & “\拆分文件”
On Error Resume Next
’*******************************************************
For K = 1 To d。Count
j = WorksheetFunction。CountIf（Columns（lsz & “：” & lsz）， X（K））
Set wdapp = CreateObject（“word。application”）
‘Set wdapp = New Word。Application
With wdapp
m = 0
。Documents。add
。Visible = True
。Documents（1）。Tables。add 。Selection。Range， j + bh， y
。Documents（1）。Tables（1）。Style = “網格型”
’複製標題********************
crr = Range（“a1：” & zdl & bh）
For Each cr In crr
m = m + 1
。Documents（1）。Tables（1）。Range。Cells（m）。Range = cr
Next
‘複製標題END*****************************
For Each rng In Range（lsz & （bh + 1） & “：” & lsz & UBound（arr））
If rng。Value = X（K） Then
brr = rng。EntireRow。Range（“a1：” & zdl & “1”）
For Each Br In brr
N = N + 1
。Documents（1）。Tables（1）。Range。Cells（N）。Range = Br
Next
End If
Next
N = bh * y
。Documents（1）。SaveAs ThisWorkbook。path & “\拆分文件\” & X（K） & “。docx”
。Quit
End With
Next K
’**********************************************************
tim2 = Timer
Sheets（shname）。Activate
MsgBox Format（tim2 - tim1， “拆分完成，共耗時：0。00秒”）， 64， “時間統計”
End Sub