在word文档中任意指定位置插入 其他Excel表数据和图片

在word文档中任意指定位置插入 其他Excel表数据和图片

对某一个目录下的若干个子目录进行处理，

在word文档中的 任意指定位置 插入 来自其他Excel表格的数据 和 图片 。。。

格的数据 和 图片

Public s As String

Sub Bestart()

jk0 = \"d:\\ncyh\\\"

s = Dir(jk0, vbDirectory)

Do While s <> \"\" ' 开始循环。

' 跳过当前的目录及上层目录。

If s <> \".\" And s <> \"..\" Then

' 使用位比较来确定 MyName 代表一目录。

If (GetAttr(jk0 & s) And vbDirectory) = vbDirectory Then

MsgBox s ' 如果它是一个目录，将其名称显示出来。

'一旦把目录名确定下来，就可以打开对应的文件了。。 其中 jk0+s+\"图\" ,jk0+s+word文档名。。。诸如此类。。。

Call Macro1

End If

End If

s = Dir ' 查找下一个目录。

Loop

End Sub

Sub Macro1()

jk0 = \"D:\\ncyh\\\"

path1 = jk0 + s + \"\\\"

file1 = path1 + \"WORD文档表.xls\"

Dim appWD As Word.Application, doc As Object

Workbooks.Open Filename:=path1 + \"WORD文档表.xls\"

Range(\"A1:F38\").Select

Selection.Copy

Set appWD = CreateObject(\"Word.Application\")

appWD.Visible = True

Set appWD = GetObject(, \"Word.Application\")

Set doc = GetObject(path1 + \"河南联通驻马店分公司\" + s + \"基站评估报告.doc\")

appWD.Visible = True

With appWD.Selection.Find

.Text = \"UNIKRANWORD文档表\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

appWD.Selection.PasteExcelTable False, False, False

Workbooks.Open Filename:=path1 + \"指标.xls\"

Range(\"A1:M7\").Select

Selection.Copy

With appWD.Selection.Find

.Text = \"UNIKRAN指标1\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

appWD.Selection.PasteExcelTable False, False, False

Windows(\"指标.xls\").Activate

Range(\"A11:M17\").Select

Selection.Copy

With appWD.Selection.Find

.Text = \"UNIKRAN指标2\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

appWD.Selection.PasteExcelTable False, False, False

With appWD.Selection.Find

.Text = \"UNIKRANFG\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

'appWD.Selection.PasteExcelTable False, False, False

appWD.Selection.InlineShapes.AddPicture Filename:=path1 + \"图\\fg.jpg\

LinkToFile:=False, SaveWithDocument:=True

With appWD.Selection.Find

.Text = \"UNIKRANRL\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

'appWD.Selection.PasteExcelTable False, False, False

appWD.Selection.InlineShapes.AddPicture Filename:=path1 + \"图\\RL.jpg\

LinkToFile:=False, SaveWithDocument:=True

With appWD.Selection.Find

.Text = \"UNIKRANBCCH\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

'appWD.Selection.PasteExcelTable False, False, False

appWD.Selection.InlineShapes.AddPicture Filename:=path1 + \"图\\BCCH.jpg\_

LinkToFile:=False, SaveWithDocument:=True

With appWD.Selection.Find

.Text = \"UNIKRANRQ\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

'appWD.Selection.PasteExcelTable False, False, False

appWD.Selection.InlineShapes.AddPicture Filename:=path1 + \"图\\RQ.jpg\

LinkToFile:=False, SaveWithDocument:=True

With appWD.Selection.Find

.Text = \"UNIKRANRLL\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

'appWD.Selection.PasteExcelTable False, False, False

appWD.Selection.InlineShapes.AddPicture Filename:=path1 + \"图\\RLL.jpg\

LinkToFile:=False, SaveWithDocument:=True

With appWD.Selection.Find

.Text = \"UNIKRANRQQ\"

.Wrap = wdFindContinue

End With

appWD.Selection.Find.Execute

appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1

appWD.Selection.TypeParagraph

appWD.Selection.MoveLeft Unit:=wdCharacter, Count:=1

'appWD.Selection.PasteExcelTable False, False, False

appWD.Selection.InlineShapes.AddPicture Filename:=path1 + \"图\\RQQ.jpg\

LinkToFile:=False, SaveWithDocument:=True

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRAN指标1\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRAN指标2\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANFG\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANWORD文档表\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

'注意， 必须先搜索替换RLL, 然后再搜索替换RL, 否则文中档会剩下一个L

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANRLL\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANRL\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

'注意，必须先搜索替换RQQ, 然后再搜索替换RQ, 否则文中档会剩下一个q

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANRQQ\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANRQ\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Selection.Find.ClearFormatting

appWD.Selection.Find.Replacement.ClearFormatting

With appWD.Selection.Find

.Text = \"UNIKRANBCCH\"

.Replacement.Text = \"\"

.Forward = True

.Wrap = wdFindAsk

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = True

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

End With

appWD.Selection.Find.Execute Replace:=wdReplaceAll

appWD.Quit (wdSaveChanges)

Windows(\"WORD文档表.xls\").Activate

ActiveWindow.Close

Windows(\"指标.xls\").Activate

ActiveWindow.Close

End Sub