简单地示范了一下,请楼主认真阅读:
'* +++++++++++++++++++++++++++++
'* Created By I Love You_Word!@ExcelHome 2005-7-26 20:32:14
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* -----------------------------
Option Explicit
Sub WriteExcel()
'运行本程序前,请确认勾选了对于MICROSOFT EXCEL 10.0(视版本情况) OBJECT LIBRARY的引用
Dim ExlApp As Excel.Application, xlsWk As Excel.Workbook, EndRange As Excel.Range, Myxls As String
Dim xlsSh As Excel.Worksheet, MySelects As String, N As Byte, MySelect As String, TF As Boolean
Dim wdMyTable As Table
On Error Resume Next '忽略错误
Myxls = "合同用款登记表1" '定义工作薄名
If Tasks.Exists("Microsoft Excel") = True Then '检测任务栏是否存在EXCEL程序
Set ExlApp = GetObject(, "Excel.Application") '如果存在,取得该程序的引用
If Tasks.Exists("Microsoft Excel - " & Myxls) = True Then '如果目标工作薄已经打开
Set xlsWk = ExlApp.Workbooks(Myxls) '取得对该工作薄的引用
Else '否则打开该工作薄
Set xlsWk = ExlApp.Workbooks.Open(ThisDocument.Path & "\" & Myxls)
End If
Else '否则创建对于EXCEL程序的引用
Set ExlApp = CreateObject("Excel.Application")
ExlApp.Visible = True '可见
TF = True '标识一个变量值
'打开目标文档,必须在与WORD文件在同一文件夹下,否则请直接引用全路径名
Set xlsWk = ExlApp.Workbooks.Open(ThisDocument.Path & "\" & Myxls)
End If
VBA.AppActivate Application.Name '激活WORD程序(如果以隐藏方式打开,则更好,无需此行)
For Each xlsSh In xlsWk.Worksheets '遍历工作表
N = N + 1 '累加
MySelects = MySelects & N & ":" & xlsSh.Name & ";" '文本累加
Next
'返回一个INPUTBOX对话框结果
MySelect = InputBox("请选择需要记录的工作表名的序号!" & vbCrLf & MySelects)
'如果为空或者用户自动输入的无效数据,则退出
If MySelect = "" Or VBA.IsNumeric(MySelect) = False Or MySelect * 1 > N Then GoTo EtSub
'取得该工作表中的最后一个空白单元格对象(B列)
Set EndRange = xlsWk.Worksheets(MySelect * 1).[B65536].End(xlUp).Offset(1, 0)
With ThisDocument
Set wdMyTable = .Tables(1) '定义一个WORD表格
'分别获得指定的单元格数据
EndRange = .Range(wdMyTable.Cell(1, 4).Range.Start, wdMyTable.Cell(1, 4).Range.End - 1)
EndRange.Offset(, 1) = .Range(wdMyTable.Cell(9, 1).Range.Start, wdMyTable.Cell(9, 1).Range.End - 1)
EndRange.Offset(, 2) = .Range(wdMyTable.Cell(11, 1).Range.Start, wdMyTable.Cell(11, 1).Range.End - 1)
End With
Exit Sub
EtSub:
If TF = True Then xlsWk.Close False: ExlApp.Quit
End Sub
'----------------------
Qv74GaJM.rar
(14.72 KB, 下载次数: 95)
|