……雖然表面上 我還是完整 那個我
可是身體𥚃 有個什麼 已被刺破
HI，大家好，我是星光。大家中午都好啊……呃……不知道該說什麼了，還是直接說正事吧……
話說我最近比較懶……不是，我最近事情比較多……你們在後臺提了很多問題，有一部分是我們之前分享過的，戳菜單【VBA相關】→【常用小代碼】，可見詳情；還有一部分是我們還沒有分享過，以後會分享……
當然啦，以後可能是很久，也可能就在明天……不過話說回來，明天的事誰說的準呢？
有蠻多的朋友詢問VBA多文件協同應用的問題，比如如何將Excel的數據寫入PPT文件？如何將Word的數據寫入Excel？
……
所以我們今天分享的VBA小代碼的內容是：
如何將Word文件的表格數據批量寫入Excel？
比如說，有一個Word文件，裡面有十幾張表格，現在急需將每個表格的數據複製到Excel，每個表格自成一份Sheet，關鍵是很不巧，你的秘書MISS李請假一個月回老家了……
操作動畫如下：
代碼如下
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
代碼已有注釋說明，這裡就不再囉嗦了。
如果你還不懂如何運行VBA代碼可以參考以下連結：
就醬~
揮手 祝安~
右下角↘你懂得~