作者:看見星光 轉自: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>
代碼已有註釋說明,這裡就不再囉嗦了。
特殊時期,小夥伴們儘量不要出門。悶了,就看看窗外的景色吧。