|
Option Explicit
'运行此代码前,请检查VBE/工具 (T):/引用(R)/引用对话框中勾选:
'Microsoft Word 11.0 Object Library(11.0视版本号不同有所不同)
Sub PrintToWord()
Dim WdApp As Word.Application, WdDoc As Word.Document, I As Byte, MyRange As Range
Dim LastRange As String, C As Range, M As Integer, N As Integer
Dim wdRange As Word.Range
' On Error Resume Next'忽略错误
Application.ScreenUpdating = False '关闭屏幕更新
LastRange = Sheets("数据").[A65536].End(xlUp).Address
Set MyRange = Sheets("数据").Range("A2:" & LastRange) '定义一个区域
Set WdApp = CreateObject("Word.Application") '创建一个WORD程序
With WdApp
.Visible = True '显示,不写此句为隐藏,可加快运行速度
'打开一个与该EXCEL工作薄同一路径下的WORD选举.DOT(模板)文件
Set WdDoc = .Documents.Open(ThisWorkbook.Path & "\选举.DOT", Visible:=False)
End With
With WdDoc
For Each C In MyRange '在指定区域中循环
If C.Offset(-1, 0).Value <> C.Value Then M = 0 Else M = M + 1 '请在数据源中直接包含此数据
If C.Offset(-1, 0).Value <> C.Value Or I = 15 Then
N = N + 1: I = 1
Set wdRange = .Range(.Content.End - 1, .Content.End - 1)
.AttachedTemplate.AutoTextEntries("记录表").Insert _
where:=wdRange, RichText:=True
Else
I = I + 1
End If
'对于WORD模板中的表格(N)
With .Tables(N)
.Cell(1, 5).Range.Text = C.Value
.Cell(1, 7).Range.Text = M '请修改数据源,直接包含此数据
.Cell(I + 3, 1).Range.Text = C.Offset(, 1).Value '姓名
.Cell(I + 3, 2).Range.Text = C.Offset(, 2).Value '性别
.Cell(I + 3, 3).Range.Text = C.Offset(, 3).Value '身份证号码
.Cell(I + 3, 4).Range.Text = C.Offset(, 4).Value '登记类型
.Cell(I + 3, 5).Range.Text = C.Offset(, 5).Value '地址
.Cell(I + 3, 6).Range.Text = C.Offset(, 6).Value '备注
End With
Next
Application.ScreenUpdating = True '恢复屏幕更新
MsgBox "EXCEL-WORD工作已结束,您可以直接打印该WORD文档!"
.ActiveWindow.Visible = True
End With
End Sub 时间紧张，未予严格测试，供参考
XcDjl89w.rar
(20.19 KB, 下载次数: 4)
[此贴子已经被作者于2006-11-2 6:50:32编辑过] | 
楼主: wangtx218
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
(不好意思字打错,现改正)
发表于 2006-10-31 06:39
