作者：看見星光 轉自：Excel之家ExcelHome
早上好啊都……呃……不知道該說什麼了，直接說正事吧……
有蠻多的朋友詢問VBA多文件協同應用的問題，比如如何將Excel的數據寫入PPT文件？如何將Word的數據寫入Excel？
群眾的呼聲當然就是我們前進的方向，所以我們今天分享的VBA小代碼的內容是：
如何將Word文件的表格數據批量寫入Excel？
比如說，有一個Word文件，裡面有十幾張表格，現在急需將每個表格的數據複製到Excel，每個表格自成一份Sheet，關鍵是很不巧，你的秘書MISS李請假一個月回老家了……
操作動畫如下：
代碼如下
<code>Sub GetWordTable() Dim WdApp As Object Dim objTable As Object Dim objDoc As Object Dim strPath As String Dim shtEach As Worksheet Dim shtSelect As Worksheet Dim i As Long Dim j As Long Dim x As Long Dim y As Long Dim k As Long Dim brr As Variant Set WdApp = CreateObject("Word.Application") With Application.FileDialog(msoFileDialogFilePicker) .Filters.Add "Word文件", "*.doc*", 1 '只顯示word文件 .AllowMultiSelect = False '禁止多選文件 If .Show Then strPath = .SelectedItems(1) Else Exit Sub End With Application.ScreenUpdating = False Application.DisplayAlerts = False Set shtSelect = ActiveSheet '當前表賦值變量shtSelect，方便代碼運行完成後葉落歸根回到開始的地方 For Each shtEach In Worksheets '刪除當前工作表以外的所有工作表 If shtEach.Name <> shtSelect.Name Then shtEach.Delete Next shtSelect.Name = "EH看見星光" '這句代碼不是無聊，作用在於……你猜…… '……其實是避免下面的程序工作表名稱重複 Set objDoc = WdApp.documents.Open(strPath) '後臺打開用戶選定的word文檔 For Each objTable In objDoc.tables '遍歷文檔中的每個表格 k = k + 1 Worksheets.Add after:=Worksheets(Worksheets.Count) '新建工作表 ActiveSheet.Name = k & "表" x = objTable.Rows.Count 'table的行數 y = objTable.Columns.Count 'table的列數 ReDim brr(1 To x, 1 To y) '以下遍歷行列，數據寫入數組brr For i = 1 To x For j = 1 To y brr(i, j) = "'" & Application.Clean(objTable.cell(i, j).Range.Text) 'Clean函數清除製表符等 '半角單引號將數據統一轉換為文本格式，避免身份證等數值變形 Next Next With [a1].Resize(x, y) .Value = brr '數據寫入Excel工作表 .Borders.LineStyle = 1 '添加邊框線 End With Next shtSelect.Select objDoc.Close: WdApp.Quit Application.ScreenUpdating = True Application.DisplayAlerts = True Set objDoc = Nothing Set WdApp = Nothing MsgBox "共獲取：" & k & "張表格的數據。"End Sub/<code>代碼已有註釋說明，這裡就不再囉嗦了。
特殊時期，小夥伴們儘量不要出門。悶了，就看看窗外的景色吧。
分享到:
閱讀更多 學點EXCEL不加班 的文章
