……虽然表面上 我还是完整 那个我
可是身体 有个什么 已被刺破
晚上好啊都……呃……不知道该说什么了，直接说正事吧……
话说我最近比较懒……不是，我最近事情比较多……你们在后台提了很多问题，有一部分是我们之前分享过的，戳菜单【VBA相关】→【常用小代码】，可见详情；还有一部分是我们还没有分享过，以后会分享……
当然啦，以后可能是很久，也可能就在明天……不过话说回来，明天的事谁说的准呢？
![]()
有蛮多的朋友询问VBA多文件协同应用的问题，比如如何将Excel的数据写入PPT文件？如何将Word的数据写入Excel？
……
厚颜无耻的说一句，群众的呼声当然就是我们前进的方向……
所以我们今天分享的VBA小代码的内容是：
如何将Word文件的表格数据批量写入Excel？
比如说，有一个Word文件，里面有十几张表格，现在急需将每个表格的数据复制到Excel，每个表格自成一份Sheet，关键是很不巧，你的秘书MISS李请假一个月回老家了……
操作动画如下：
代码如下
Sub GetWordTable() '读取word中的表格数据到excel 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 k As Long, x As Long, y As Long Dim i As Long, j As Long Dim brr As Variant On Error Resume Next 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 & "表" objTable.Range.Copy '整表复制 ActiveSheet.Paste 'word表粘贴到excel，保留word表的格式 '整表复制的方法无法避免身份证之类数据的变形,如果有这样的数据，最好使用如下单元格遍历 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
代码已有注释说明，这里就不再啰嗦了。
就酱~
挥手 祝安~
|
|
转播
