作者:乔山办公网日期:
返回目录:word文档
试试下面的代码,在网上找的
Sub 宏1()
Dim wordapp As Object
Dim mydoc
Dim mypath$, myname$
Dim wdRng As Object
Dim pos1%, pos2% '定义找到的字段的首位位置
Application.DisplayAlerts = False
Set wordapp = CreateObject("word.application")
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.doc*")
Set mydoc = wordapp.Documents.Open(mypath & myname)
Set wdRng = mydoc.Range
wdRng.Find.Execute ("(一)")
pos1 = wdRng.Start
Set wdRng = mydoc.Range
wdRng.Find.Execute ("五、")
pos2 = wdRng.Start
mydoc.Range(pos1, pos2).Copy '选中找到的两个字段中间的e799bee5baa6e58685e5aeb9361内容
mydoc.Close False
wordapp.Quit
Worksheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
试试下面的代码e68a847a64338:
Sub 宏1()
Dim wordapp As Object
Dim mydoc
Dim mypath$, myname$
Dim wdRng As Object
Dim pos1%, pos2% '定义找到的字段的首位位置
Application.DisplayAlerts = False
Set wordapp = CreateObject("word.application")
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.doc*")
Set mydoc = wordapp.Documents.Open(mypath & myname)
Set wdRng = mydoc.Range
wdRng.Find.Execute ("(一)")
pos1 = wdRng.Start
Set wdRng = mydoc.Range
wdRng.Find.Execute ("五、")
pos2 = wdRng.Start
mydoc.Range(pos1, pos2).Copy '选中找到的两个字段中间的内容
mydoc.Close False
wordapp.Quit
Worksheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
录制百宏是给你一个框架,然后你要会修改你录度制的宏才行。
Excel.Application.Sheets(3).Activate
Excel.Application.Sheets(3).Range("L1:L1").Select '选中当前激活回表的L1格子
sstr=Selection.value '将选中的答区域进行复制
WordObject.Application.Activate
WordObject.ActiveWindow.Selection.range=sstr
下面这段代码是实现将excel表格插入到指定word模板的指定位置。可以参考一下。
Sub 插入表格()
Dim SS As String
Dim wdoc As New Word.Application
Dim 当前路径, 导出路径文件名, i, j
Dim Str1, Str2, Str3
Dim tarr(1 To 100, 1 To 3)
Dim filepathname As String
当前路径 = ThisWorkbook.Path
最后行号 = Sheets("数字表格").Range("B30").End(xlUp).Row
判断 = 0
' 导出文件名 = "报告作品.doc"
filepathname = 当前路径 & "\" & Tfile
If Dir(filepathname) = "" Then
'文件不存在
FileCopy 当前路径 & "\" & Sfile, 当前路径 & "\" & Tfile
End If
Sheets("数字表格").Select
For i = KShh To 最后行号
tarr(i - KShh + 1, 1) = Sheets("数字表格").Cells(i, 1)
tarr(i - KShh + 1, 2) = Sheets("数字表格").Cells(i, 2)
tarr(i - KShh + 1, 3) = Sheets("数字表格").Cells(i, 3)
Next i
j = i - KShh '记录需替换文本个数
导出路径文件名 = 当前路径 & "\" & Tfile
With wdoc '打开word文档
.Documents.Open 导出路径文件名
.Visible = True
End With
For i = 1 To j
Str1 = tarr(i, 1)
Str2 = tarr(i, 2)
Str3 = tarr(i, 3)
Range(Str3).Select
Application.CutCopyMode = False
Selection.Copy
With wdoc
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
.Selection.Text = "" '替换字符串
.Selection.PasteExcelTable False, False, False '粘贴为表格
.Selection.WholeStory
.Selection.Font.Size = 12
With .Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
.Selection.Tables(1).PreferredWidthType = 3
.Selection.Tables(1).PreferredWidth = .CentimetersToPoints(15)
End If
' wdoc.Documents.Save
' wdoc.Quit
' Set wdoc = Nothing
End With
Next i
With wdoc '存盘e799bee5baa6e79fa5e98193e59b9ee7ad94366后关闭WORD文档
wdoc.Documents.Save
wdoc.Quit
Set wdoc = Nothing
End With
Sheets("首页").Select
End Sub