[求助]请教word VBA问题

mutian2158

      在一个excel工作薄中包含6个工作表，每个工作表中有100个格式相同的依次向下排列的表格，每个表格中有不同的数据。现在需要将每个工作表中的表格依次复制粘贴到word文档中，每个工作表对应一个word文档。用手工一个一个表格的操作工作量大且烦人，请问可以用VBA过程来自动执行么？

另有 word文档里面的表格都要设置成统一格式，录制了宏来执行，但对于每个表格都要执行一次宏，可否更改为执行一次即可全部表格设置完毕？

上传数据样本以供参考

dBq2E7K3.rar (35.27 KB, 下载次数: 10)

2007-5-15 15:23 上传

点击文件名下载附件
[求助]请教word VBA问题

cuteword

对第二个问题，可以用灵感百宝箱，说明书中有类似的例子！

最新版本的可以来信索取cuteword@21cn.com

chylhr

'楼主只上传了一个工作表，只以代码假设其他工作与这个工作表类似

'在运行前需添加对Microsoft Excel Object Library 的引用

Sub main()

   '主程序

   Dim myAppExcel As New Excel.Application

   Dim mySheet As Worksheet

   If Not myAppExcel.Dialogs(xlDialogOpen).Show Then

      Exit Sub

   End If

   For Each mySheet In myAppExcel.ActiveWorkbook.Sheets

      myAppExcel.Range(mySheet.Cells(1, 1), mySheet.Cells.SpecialCells(xlCellTypeLastCell)).Copy '对数据区复制

      PasteToWord

   Next

   myAppExcel.Quit

End Sub

 

Sub PasteToWord()

   Dim myDoc As Document, myRange As Range, myTable As Table

   Set myDoc = Documents.Add

   myDoc.Content.PasteAndFormat wdFormatPlainText   '以文本方式粘贴

   '以下代码将文字转化为表格

   Set myRange = myDoc.Content

   Do While myRange.Find.Execute(FindText:="日期*^13*^13", Forward:=True, _

                    Format:=False, Wrap:=wdFindStop, MatchWildcards:=True)

      Set myTable = myRange.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=17, _

          NumRows:=2, AutoFitBehavior:=wdAutoFitFixed)

      setTable myTable

      Set myRange = ActiveDocument.Content   'myRange需重新定义

   Loop

   '以下代码删除文档中多余的制表位

   Set myRange = myDoc.Content

   With myRange.Find

      .ClearFormatting

      .Text = "^t{2,}"

chylhr

      .Replacement.Text = ""

      .Forward = True

      .Format = False

      .Wrap = wdFindStop

      .MatchWildcards = True

      .Execute Replace:=wdReplaceAll

   End With

   '以下代码将剩余的制表位替换与“-”

   Set myRange = myDoc.Content

   With myRange.Find

      .ClearFormatting

      .Text = "^t"

      .Replacement.Text = "-"

      .Forward = True

      .Format = False

      .Wrap = wdFindStop

      .MatchWildcards = True

      .Execute Replace:=wdReplaceAll

   End With

End Sub

 

Sub setTable(myTable As Table)

   '本过程对表格进行设置

   '不知道楼主对表格的设置有什么要求

   '这里只示例性的对表格应用了一个样式，用户可修改样式来达到对表格统一设置

   myTable.Style = "网格型"    '需要02版本以上

End Sub