[求助]对数据直接插入表格的实现

firewzy

近来有意编写一些关于WORD中自动化格式设置的程序，在碰到对多行数据直接插入表格的编程实现时，感觉棘手。这是我要处理前的文档和处理后的文档，望各位帮我!

EkOVdEWU.rar (7.58 KB, 下载次数: 30)

2005-7-6 02:39 上传

点击文件名下载附件
[求助]对数据直接插入表格的实现

konggs

这个行吗？

Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=6, _ NumRows:=6, AutoFitBehavior:=wdAutoFitFixed

firewzy

如果有好多这样的数据需要插入表格的话，预先又不知道行数，怎么实现自动化插入表格呢？

守柔

先试试这个代码：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-7-6 21:02:06 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub Example() Dim i As Paragraph, StartRange As Long, EndRange As Long, MyTableRange As Range Dim MyRange As Range, TempPar As Paragraph '定义一个常量为四个制表符 Const RepLable As String = vbTab & vbTab & vbTab & vbTab '定义一个粗体字常量,其值为"宗地面积量算表" Const BoldText As String = "宗地面积量算表" '定义一个表格第一个单元格的常量,其值为"所在图幅号" Const TableFirstCellText As String = "所在图幅号" On Error Resume Next '忽略错误 Application.ScreenUpdating = False '关闭屏幕更新 With ThisDocument For Each i In .Paragraphs '在本文档的段落中循环 '如果段落起始位置小于指定的结束标记位置(即已循环过),则进入下一段落循环 If i.Range.Start < EndRange Then GoTo GN With i '定义一个MyRange对象,为去除段落标记的文字区域部分 Set MyRange = ThisDocument.Range(i.Range.Start, i.Range.End - 1) '去除五个制表位(如果文本中带有五个制表位的话,则替换为"") MyRange = VBA.Replace(MyRange, RepLable & vbTab, "") '去除四个制表位(如果文本中带有四个制表位的话,则替换为"") MyRange = VBA.Replace(MyRange, RepLable, "") '如果段落文本起始为指定文本时 If VBA.InStr(.Range, BoldText) = 1 Then '设置其段落格式,粗体,16号字体,段落居中 .Range.Bold = True .Range.Font.Size = 16 .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '如果段落文本中包含指定的文本(表格)时 ElseIf VBA.InStr(.Range, TableFirstCellText) = 1 Then '取得起始位置 StartRange = .Range.Start '定义一个MyRange对象,为从下一个段落开始到文档末的区域位置 Set MyRange = ThisDocument.Range(i.Next.Range.Start, ThisDocument.Content.End) '在指定的MyRange对象的段落中循环 For Each TempPar In MyRange.Paragraphs '如果找到指定的文本,则取得表格末尾段落位置,并退出该循环 If VBA.InStr(TempPar.Range, TableFirstCellText) = 1 Then EndRange = TempPar.Range.End: Exit For Next '定义一个RANGE对象 Set MyTableRange = ThisDocument.Range(StartRange, EndRange) '以制表位为分隔符,转换为表格,并设置为网格型 MyTableRange.ConvertToTable Separator:=wdSeparateByTabs, AutoFitBehavior:=wdAutoFitFixed MyTableRange.Style = "网格型" End If End With GN: Next End With Application.ScreenUpdating = True '恢复屏幕更新 End Sub '----------------------

如果你觉得还有什么没有说清楚的，请上传具有代表性的文档。

firewzy

守柔斑竹，为什么只有将代码中的“ThisDocument”替换为“ActiveDocument”，才可以成功运行，否则就不行呢？

守柔

你看一下我的代码头，你可以将代码直接粘贴于"修改前"文档的"THISDOCUMENT"代码窗口中,出现你上述问题的情况是,你没有正确粘贴此代码,而是将代码粘贴到了别的工程代码窗口中了.

欲判断是否在你需要的代码窗口中,最简单的方法是看一下VBE编辑器的标题栏,是否为"修改前"文档名.

另外,请你告诉我,运行结果是否满足你的要求?

firewzy

非常感谢守柔，我已经非常满意了。

也许是我刚开始没有说太多要求，全部的文档字体为宋体，除“宗地面积量算表”为三号字外，其余为小四；表格中字应居中。这些都是小意思了，自己搞定了。

再次感谢守柔！佩服之至！

firewzy

Sub Example() Dim i As Paragraph, StartRange As Long, EndRange As Long, MyTableRange As Range Dim MyRange As Range, TempPar As Paragraph '定义一个常量为四个制表符 Const RepLable As String = vbTab & vbTab & vbTab & vbTab '定义一个粗体字常量,其值为"宗地面积量算表" Const BoldText As String = "宗地面积量算表" '定义个字常量，其值为"土地使用者: " Const tdText As String = "土地使用者:" '定义个字常量，其值为"面积(平米): " Const mjText As String = "面积(平米):" '定义一个表格第一个单元格的常量,其值为"所在图幅号" Const TableFirstCellText As String = "所在图幅号" On Error Resume Next '忽略错误 Application.ScreenUpdating = False '关闭屏幕更新 With ActiveDocument Set MyRange = .Range(ActiveDocument.Content.Start, ActiveDocument.Content.End) MyRange.Font.Size = 12 MyRange.Font.Name = "宋体" For Each i In .Paragraphs '在本文档的段落中循环 '如果段落起始位置小于指定的结束标记位置(即已循环过),则进入下一段落循环 If i.Range.Start < EndRange Then GoTo GN With i '定义一个MyRange对象,为去除段落标记的文字区域部分 Set MyRange = ActiveDocument.Range(i.Range.Start, i.Range.End - 1) '去除五个制表位(如果文本中带有五个制表位的话,则替换为"") MyRange = VBA.Replace(MyRange, RepLable & vbTab, "") '去除四个制表位(如果文本中带有四个制表位的话,则替换为"") MyRange = VBA.Replace(MyRange, RepLable, "") '去除多余制表位 MyRange = VBA.Replace(MyRange, tdText & vbTab, tdText) MyRange = VBA.Replace(MyRange, mjText & vbTab, mjText) '如果段落文本起始为指定文本时 If VBA.InStr(.Range, BoldText) = 1 Then '设置其段落格式,粗体,16号字体,段落居中 .Range.Bold = True .Range.Font.Size = 16 .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '如果段落文本中包含指定的文本(表格)时 ElseIf VBA.InStr(.Range, TableFirstCellText) = 1 Then '取得起始位置 StartRange = .Range.Start '定义一个MyRange对象,为从下一个段落开始到文档末的区域位置 Set MyRange = ActiveDocument.Range(i.Next.Range.Start, ActiveDocument.Content.End) '在指定的MyRange对象的段落中循环 For Each TempPar In MyRange.Paragraphs '如果找到指定的文本,则取得表格末尾段落位置,并退出该循环 If VBA.InStr(TempPar.Range, TableFirstCellText) = 1 Then EndRange = TempPar.Range.End: Exit For Next '定义一个RANGE对象 Set MyTableRange = ActiveDocument.Range(StartRange, EndRange) '以制表位为分隔符,转换为表格,并设置为网格型 MyTableRange.ConvertToTable Separator:=wdSeparateByTabs, AutoFitBehavior:=wdAutoFitFixed MyTableRange.Style = "网格型" MyTableRange.ParagraphFormat.Alignment = wdAlignParagraphCenter End If End With GN: Next End With Application.ScreenUpdating = True '恢复屏幕更新 End Sub