楼主
kevinchengcw |
Q: 如何用vba代码将excel中数据导入到word表格中？
A: 代码如下：
- Sub test()
- Dim mTable As Table, mCell As Cell, Str$, WB, Rng, Dic As Object, Arr, N&, xlApp As Object
- On Error Resume Next '设置容错
- Set xlApp = CreateObject("excel.application") '创建一个excel项目,用于引用excel的函数
- Set Dic = CreateObject("scripting.dictionary") '创建字典用于装载数据
- Set WB = GetObject(ThisDocument.Path & "\数据源.xlsx") '打开数据源文件
- With WB.worksheets(1) '提取数据源文件中第一个表中的指定位置数据
- For Each Rng In .[b2].Resize(.Cells(.Rows.Count, 2).End(3).Row - 1, 1) '循环指定标题列各单元格
- If Rng <> "" Then Dic.Add Rng.Offset(-1).Value & vbTab & Rng.Value, Join(xlApp.transpose(xlApp.transpose(Rng.Resize(1, .Cells(Rng.Row, .Columns.Count).End(1).Column))), vbTab) '如果数据不为空则存入字典中(因存在相同字段,故与上面单元格字段组合)
- Next Rng
- End With
- WB.Close False '关闭数据源文件
- Set WB = Nothing '清空工作簿项目
- Set xlApp = Nothing '清空excel项目
- For Each mTable In ThisDocument.Tables '循环本文档中各个表格
- For Each mCell In mTable.Range.Cells '循环表格中各个单元格
- If mCell.ColumnIndex = 1 And mCell.RowIndex > 1 Then '如果是表格第二行以上的第一列,则
- Str = "" '清空字段,防止出错
- Str = Replace(mTable.Cell(mCell.RowIndex - 1, mCell.ColumnIndex).Range.Text, Chr(13) & Chr(7), "") & vbTab & Replace(mCell.Range.Text, Chr(13) & Chr(7), "") '组合字段,用于与字典的keys进行判断
- If Dic.Exists(Str) Then '如果存在该字段的key,则
- Arr = Split(Dic(Str), vbTab) '将item项拆分放入数组
- For N = LBound(Arr) + 1 To mTable.Range.Columns.Count - 1 '循环数据中第二个到表格列数范围的数组数据
- mTable.Cell(mCell.RowIndex, mCell.ColumnIndex + N).Range.Text = Format(Arr(N), "#,##0.00") '将数据依指定格式写入对应单元格中
- Next N
- End If
- End If
- Next mCell
- Next mTable
- Set Dic = Nothing '清空字典项目
- End Sub
也可以利用excel表格中的vba实现此功能。 |