在d:\ncyh目录下

有各个子目录

例如： 目录名为：  凤鸣谷风景区 

在图目录下

有6个文件。。

BCCH:

FG: 覆盖

RL：电平图

RLL：电平拉线

RQ： 质量图

RQQ： 质量拉线

程序运行效果：

直接将所有的图， 插到一个WORD文档的指定位置

、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、

还有两个表

例如： 目录名为：  凤鸣谷风景区  根目录下

 
一个表名为： WORD文档表

另一个表名为：指标

打开两个表，  把表的内容复制粘贴到一个WORD文档的指定位置

=========================================

该WORD文档的 文件名格式为= 河南联通驻马店分公司+ 目录名+ 基站评估报告

河南联通驻马店分公司凤鸣谷风景区基站评估报告

 

========================================

我在考虑 是否可以用EXCLE 录制出WORD VBA  ?

==========================================

我在考虑  是否可以在WORD中设置一些特殊的关键词， 然后用搜索替换的方法， 把特殊的关键词替换掉， 然后在替换处插入目标内容， 例如表格或者图片。。。

首先尝试这种方法：

==========================================
UNIKRANWORD文档表
UNIKRANFG

===========================================
怎样在WORD VBA 中  打开一个EXCLE表格 ， 并复制粘贴表格内容到WORD文档中。。。？

怎样在WORD VBA 中  打开一个EXCLE表格？

'首先alt+f11,菜单： 工具---引用, 勾选microsoft excel 12.0 object library,然后点击“确定”
Sub op()
Dim app As New Excel.Application
Dim wb As Excel.Workbook
Set wb = app.Workbooks.Open("D:\ncyh\凤鸣谷风景区\WORD文档表.xls")

app.Quit
End Sub

 

================

  Dim app As New Excel.Application
Dim wb As Excel.Workbook
    Documents.Open FileName:="D:\ncyh\凤鸣谷风景区\河南联通驻马店分公司凤鸣谷风景区基站评估报告.doc", ConfirmConversions _
        :=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "UNIKRANWORD文档表"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute

Set wb = app.Workbooks.Open("D:\ncyh\凤鸣谷风景区\WORD文档表.xls")
    wb.Sheets("WORD文档表").Range("A1:F38").Select
    Selection.Copy
    Documents.Open FileName:="D:\ncyh\凤鸣谷风景区\河南联通驻马店分公司凤鸣谷风景区基站评估报告.doc", ConfirmConversions _
        :=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
 
    Selection.PasteExcelTable False, False, False

=======================

事实证明用 EXCEL VBA  然后调用 WORD 效果比较好。。在WORD中设置一些特殊的关键词， 然后用搜索替换的方法， 把特殊的关键词替换掉， 然后在替换处插入目标内容， 例如表格或者图片。。。

=======================

在excel的vb编辑器菜单中，选“工具”---“引用”---在那列表中往下找“Microsoft Word 9.0 Object Library”，把它前面的框勾上，确定。
这样执行就没错了。

Sub Macro1()

Dim appWD As Word.Application, doc As Object
Range("A1:C3").Select
Selection.Copy

Set appWD = CreateObject("Word.Application")
appWD.Visible = True
Set appWD = GetObject(, "Word.Application")
Set doc = GetObject("D:\doc1.doc")
appWD.Visible = True

With appWD.Selection.Find
.Text = "指定位置"
.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.Quit (wdSaveChanges)
End Sub

不过在直接用你的程序运行时提示
“appWD.Selection.PasteExcelTable False, False, False”
有错，我直接把“ExcelTable False, False, False”删了就没有报错了，但是不知道是什么原因。

==========================

http://zhidao.baidu.com/question/73540445.html?fr=qrl&cid=87&index=2

用VBA把Excel中的表粘贴到Word？

把Excel中的表格（比如A1：C3）粘贴到word中的指定位置（比如粘贴到“指定位置”这几个字之后），

==============================

 

   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
'appWD.Quit (wdSaveChanges)

 Workbooks.Open Filename:="D:\ncyh\凤鸣谷风景区\指标.xls"

    Range("A1:M7").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指标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
'appWD.Quit (wdSaveChanges)

 Workbooks.Open Filename:="D:\ncyh\凤鸣谷风景区\指标.xls"

    Range("A11:M17").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指标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
appWD.Quit (wdSaveChanges)

 

End Sub
   

 

 

==================

   Sub Macro1()

Dim appWD As Word.Application, doc As Object

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

    Range("A1:F44").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

 

appWD.Quit (wdSaveChanges)

 

End Sub
   
======================
插入图片：

  Selection.InlineShapes.AddPicture FileName:="D:\ncyh\凤鸣谷风景区\图\fg.jpg", _
        LinkToFile:=False, SaveWithDocument:=True

======================

 Sub Macro1()

Dim appWD As Word.Application, doc As Object

 

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 = "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 = "UNIKRANRBCCH"
.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 = "UNIKRANRRQ"
.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 = "UNIKRANRRQQ"
.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.Quit (wdSaveChanges)

 

End Sub
   

 

 

 

////

 

下一步就是要编写一个函数， 然后可以读取某个目录下有几个子目录。。。并将目录名赋予某几个字符串。。。

、、、、