目录
第五章：Word与Excel双剑合璧
5-1 如何在Word中创建和获取Excel程序？
5-2 在Word中读取Excel单元格数据-1（单元格获取法）
5-3 在Word中读取Excel单元格数据-2（数组获取法）
5-4 Word中处理Excel数据并将结果写入Word
5-5 实例：Word中将Excel数据拆分到Word文档
5-6 在Word中将数据写入Excel单元格的几种方法
5-7 Word数据写入Excel实例-1
5-8 Word数据写入Excel实例-2
第五章：Word与Excel双剑合璧
5-1 如何在Word中创建和获取Excel程序？
Sub创建与关闭excel对象()
DimxlApp As Object, wbOpen, ws
SetxlApp = CreateObject("excel.application")
xlApp.Visible = True'显示出excel程序
SetwbOpen = xlApp.Workbooks.Open(ThisDocument.Path & "\1.xlsx")'打开工作簿
Setws = wbOpen.Sheets(1)
Debug.Print ws.Name
wbOpen.Close'关闭工作簿
xlApp.Quit'退出程序
SetxlApp = Nothing'清空内存
End Sub
5-2在Word中读取Excel单元格数据-1（单元格获取法）
Sub读取Excel单元格数据()
DimxlApp, wb, ws, intLastRow As Integer, a As Integer, v1, v2, v3
SetxlApp = CreateObject("excel.application")
xlApp.Visible = True
Setwb = xlApp.Workbooks.Open(ThisDocument.Path & "\demo.xlsx")
Setws = wb.Sheets("员工表")
intLastRow = ws.usedrange.Rows.Count
Fora = 2 To intLastRow
v1 = ws.Cells(a, 1).Value
v2 = ws.Cells(a, 2).Value
v3 = ws.Cells(a, 3).Value
Debug.Print v1, v2, v3
Next
xlApp.Quit
SetxlApp = Nothing
End Sub
5-3在Word中读取Excel单元格数据-2（数组获取法）
Sub读取Excel单元格数据2()
DimxlApp, wb, ws, intLastRow As Integer, a As Integer, v1, v2, v3, arr
SetxlApp = CreateObject("excel.application")
xlApp.Visible = True
Setwb = xlApp.Workbooks.Open(ThisDocument.Path & "\demo.xlsx")
Setws = wb.Sheets("员工表")
intLastRow = ws.usedrange.Rows.Count
arr = ws.Range("a2:c" & intLastRow)
Fori = 1 To UBound(arr)
v1 = arr(i, 1)
v2 = arr(i, 2)
v3 = arr(i, 3)
Debug.Print v1, v2, v3
Next
'也可以用下面方法获取
Fori = 1 To UBound(arr)
ar = xlApp.Index(arr, i)'应用excel的index函数
v1 = ar(1)
v2 = ar(2)
v3 = ar(3)
Debug.Print v1, v2, v3
Next
xlApp.Quit
SetxlApp = Nothing
End Sub
Excel与Word双剑合壁:
office家庭产品：word、excel、access、powerpoint...都是使用VBA语言。
不同点：它们的对象模型不一样（workbooks是excel中的，document是word中的）
应用程序之间可以实现相互访问
要想访问Excel，首先要建立对它的连接
1.前期绑定：工具--引用--Microsoft Excel14.0 Object Library
2.后期绑定：Setwdap=createobject("Excel.application")
Sub使用前期绑定更方便代码输入()
DimxlApp As Excel.Application'声明wapp变量为Excel程序对象类型
Dimwb As Workbook
SetxlApp = New Excel.Application'创建一个excel对象
xlApp.Visible = True'显示出excel对象
Setwb = xlApp.Workbooks.Add'新建一个工作簿
wb.Sheets(1).Range("a1") = 20'sheets没有申明变量，所以输入其属性、方法时没有代码提示
Dimws As Sheets
Setws = wb.Sheets
SetxlApp = Nothing
End Sub
5-4 Word中处理Excel数据并将结果写入Word
Sub处理Excel数据并将结果写入Word()
DimxlApp, wb, ws, intLastRow As Integer, a As Integer, v1, v2, v3, arr, t As Table
SetxlApp = CreateObject("excel.application")
xlApp.Visible = True
Sett = ThisDocument.Tables.Add(Selection.Range, 1, 3, 1)'最后一个参数（1）表示表格有网格
t.Cell(1, 1).Range.Text = "姓名": t.Cell(1, 2).Range.Text = "年龄": t.Cell(1, 3).Range.Text = "籍贯"
Setwb = xlApp.Workbooks.Open(ThisDocument.Path & "\demo.xlsx")
Setws = wb.Sheets("员工表")
intLastRow = ws.usedrange.Rows.Count
arr = ws.Range("a2:c" & intLastRow)
Fori = 1 To UBound(arr)
v1 = arr(i, 1)
v2 = arr(i, 2)
v3 = arr(i, 3)
Ifv2 >= 30Then
t.Select
Selection.InsertRowsBelow 1
a = t.Rows.Last.Index
t.Cell(a, 1).Range.Text = v1
t.Cell(a, 2).Range.Text = v2
t.Cell(a, 3).Range.Text = v3
End If
Next
xlApp.Quit
SetxlApp = Nothing
End Sub
5-5实例：Word中将Excel数据拆分到Word文档
Sub将Excel数据拆分到Word文档()
DimxlApp, wb, ws, doc As Document
SetxlApp = CreateObject("excel.application")
Setwb = xlApp.Workbooks.Open(ThisDocument.Path & "\名篇.xlsx")
Setws = wb.Sheets("sheet1")
arr = ws.Range("a2:b" & ws.usedrange.Rows.Count).Value
Forn = 1 To UBound(arr, 1)
Setdoc = Documents.Add
doc.Range(0).Text = arr(n, 1) & Chr(13)
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter'居中
Selection.EndKey wdStory
Selection.Text = arr(n, 2)
Selection.ParagraphFormat.FirstLineIndent = CentimetersToPoints(0.75)'首先缩进0.75厘米，CentimetersToPoints(0.75)表示将0.75厘米转化为磅值
doc.SaveAs2 ThisDocument.Path & "\结果\" & arr(n, 1) & ".docx"
doc.Close
Next
wb.Close
xlApp.Quit
SetxlApp = Nothing
End Sub
5-6在Word中将数据写入Excel单元格的几种方法
Sub将数据写入Excel单元格的几种方法()
DimxlApp, wb, ws, arr1(1 To 3, 1 To 2) As Integer, arr2
arr2 = Array(Array(1, 2), Array(10, 20), Array(100, 200))'一维套一维的数组
SetxlApp = CreateObject("excel.application")
xlApp.Visible = True
arr2 = xlApp.Transpose(xlApp.Transpose(arr2))'转置
Setwb = xlApp.Workbooks.Add'创建工作簿
Setws = wb.Sheets(1)
ws.Range("a1") = "word VBA"'单值
ws.Range("a2:c2") = Array(100, 200, 300)'一维数组
ws.Range("a3:b5") = arr1'二维数组
ws.Range("a6:b8") = arr2'转置后的二维数组
xlApp.Quit
SetxlApp = Nothing
End Sub
5-7 Word数据写入Excel实例-1
WORD中的表格如下：
工号姓名性别年龄入职时间身高学历职务
NED001 阿汤男 30 2006/11/25 171 硕士普工
NED002 陈虹女 29 2005/08/20 169 本科普工
SubWord数据写入Excel实例()
DimintRow As Integer, intAge As Integer, arr(), i As Integer, t As Table
DimstrId As String, strName As String, strSex As String, dat As Date, strH As String, strX As String, strZ As String
Sett = ThisDocument.Tables(1)
ForintRow = 2 To t.Rows.Count
intAge = Split(t.Cell(intRow, 4).Range.Text, Chr(13))(0)
IfintAge >= 30Then
strId = Split(t.Cell(intRow, 1).Range.Text, Chr(13))(0)
strName = Split(t.Cell(intRow, 2).Range.Text, Chr(13))(0)
strSex = Split(t.Cell(intRow, 3).Range.Text, Chr(13))(0)
dat = Split(t.Cell(intRow, 5).Range.Text, Chr(13))(0)
strH = Split(t.Cell(intRow, 6).Range.Text, Chr(13))(0)
strX = Split(t.Cell(intRow, 7).Range.Text, Chr(13))(0)
strZ = Split(t.Cell(intRow, 8).Range.Text, Chr(13))(0)
n = n + 1
ReDimPreserve arr(1 To n)
arr(n) = Array(strId, strnmae, strSex, intAge, dat, strH, strX, strZ)
End If
Next
SetxlApp = CreateObject("excel.application")
xlApp.Visible = True
Setwb = xlApp.Workbooks.Add
arr = xlApp.Transpose(xlApp.Transpose(arr))
wb.Sheets(1).Range("a1").Resize(n, 8) = arr
wb.SaveAs ThisDocument.Path & "\筛选结果.xlsx"
xlApp.Quit
SetxlApp = Nothing
End Sub
5-8 Word数据写入Excel实例-2
WORD 中有4个表格（每季度一张表），表格样式如下：
1 季度统计表
产品业绩(万元)
a 789
b 9955
c 785
SubWord数据写入Excel实例2()
Dimt As Table, intRow As Integer, q, v0, v1, v2, xlApp, wb, ws, i As Integer
SetxlApp = CreateObject("excel.application")
Setwb = xlApp.Workbooks.Add
Setws = wb.Sheets(1)
ws.Cells(1, 1) = "季度": ws.Cells(1, 2) = "产品": ws.Cells(1, 3) = "业绩"
ForEacht In ThisDocument.Tables
q = q + 1
ForintRow = 2 To t.Rows.Count
v0 = "第" & q & "季度"
v1 = Split(t.Cell(intRow, 1).Range.Text, Chr(13))(0)
v2 = Split(t.Cell(intRow, 2).Range.Text, Chr(13))(0)
i = i + 1
ws.Range("a" & i + 1).Resize(1, 3) = Array(v0, v1, v2)
Next
Next
wb.SaveAs ThisDocument.Path & "\提取结果.xlsx"
xlApp.Quit
SetxlApp = Nothing
End Sub
计算机科学与技术 & 计算机网络技术：双专业课程体系完全导航指南
