EXCEL VBA 自动在WORD文档指定位置插入图片和粘贴表格_unikran

http://blog.sina.com.cn/u/1420869803

首页博文目录关于我

个人资料

微博

加好友发纸条

写留言加关注

博客等级：
博客积分：

博客访问：
关注人气：
获赠金笔：0支
赠出金笔：0支
荣誉徽章：

正文字体大小：大中小

EXCEL VBA 自动在WORD文档指定位置插入图片和粘贴表格

(2010-08-13 16:18:01)

标签：

移动宽带

it

分类：移动、宽带__博客张凯_unikran

1 必须在D:\ncyh目录下

2 在该目录下，不能有其他文件。。只能放目录，

3 必须使用模板文件：指标.xls，河南联通驻马店分公司凤鸣谷风景区基站评估报告（BIAOZHUN）.doc

4 按CTRL+F8, 点编辑，点工具菜单，---引用----microsoft word 11.0 libery.......

5 首先拷贝河南联通驻马店分公司凤鸣谷风景区基站评估报告（BIAOZHUN）.doc 到各目录，然后将文件名改为对应目录

Sub Macro1()

Dim appWD As Word.Application, doc As Object

Workbooks.Open Filename:="D:\ncyh\凤鸣谷风景区\WORD文档表.xls"

Range("A1:F38").Select
Selection.Copy

Set appWD = CreateObject("Word.Application")
appWD.Visible = True
Set appWD = GetObject(, "Word.Application")
Set doc = GetObject("D:\ncyh\凤鸣谷风景区\河南联通驻马店分公司凤鸣谷风景区基站评估报告.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:="D:\ncyh\凤鸣谷风景区\指标.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:="D:\ncyh\凤鸣谷风景区\图\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:="D:\ncyh\凤鸣谷风景区\图\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:="D:\ncyh\凤鸣谷风景区\图\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:="D:\ncyh\凤鸣谷风景区\图\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:="D:\ncyh\凤鸣谷风景区\图\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:="D:\ncyh\凤鸣谷风景区\图\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

阅读┊ 收藏 ┊ 喜欢 ▼ ┊打印┊举报/Report

前一篇：初步修正宏。这次才是没问题。。。

后一篇：Excel VBA 读取某个目录下有几个子目录和文件

新浪BLOG意见反馈留言板　欢迎批评指正