示例需求:Word文档中的有多个表格,其中最后一个表格为汇总表格
,其他的为数据表格
,如下图中左侧所示。
现在需要根据Category1
和Category2
,在数据表格中查找,如果找到匹配行,那么
- 为数据表中改行创建书签Bookmark
- 在
汇总表格
中记录匹配行位置,例如表格Table_1中第3行
- 为上述文字添加超链接指向书签
完成后的效果如下图中右侧所示。
示例代码如下。
Sub LinkMatches()Dim i As Long, j As Long, r As LongDim oDoc As Document, tabIndex As StringDim sumTab As Table, oTab As TableDim sKey1 As String, sKey2 As String, bFirst As BooleanDim cellRange As Range, paraRng As RangeConst S_ROW = 3Set oDoc = ThisDocumentSet sumTab = oDoc.Tables(oDoc.Tables.Count)For r = 3 To sumTab.Rows.CountsKey1 = GetTxt(sumTab.Cell(i, 2).Range.Text) & "|" & _GetTxt(sumTab.Cell(i, 3).Range.Text)Set cellRange = sumTab.Cell(i, 5).RangecellRange.Text = ""bFirst = TrueFor i = 1 To oDoc.Tables.Count - 1Set oTab = oDoc.Tables(i)tabIndex = "Table_" & iFor j = 3 To oTab.Rows.CountsKey2 = GetTxt(oTab.Cell(j, 2).Range.Text) & "|" & _GetTxt(oTab.Cell(j, 3).Range.Text)If sKey1 = sKey2 ThenoTab.Rows(j).Range.Bookmarks.Add tabIndex & "Row" & jIf Not bFirst ThencellRange.InsertAfter vbCrEnd IfcellRange.InsertAfter "表格" & tabIndex & "中第" & j & "行"Set paraRng = cellRange.Paragraphs.Last.RangeparaRng.MoveEnd wdCharacter, -1cellRange.Hyperlinks.Add Anchor:=paraRng, _Address:="", SubAddress:=tabIndex & "Row" & j, _TextToDisplay:="表格" & tabIndex & "中第" & j & "行"bFirst = FalseEnd IfNextNextNext
End Sub
【代码解析】
第7行代码定义常量,指定数据行从表格第3行开始。
第8行代码获取当前文档对象。
第9行代码获取文档中最后一个表格对象,即汇总表格。
第10行代码在汇总表格中从第3行开始遍历每一行。
第11~12行代码读取第2列和第3列,并组合为关键字。
第13行代码获取第5列单元格。
第14行代码清空第5列单元格。
第15行代码设置首个匹配记录标志位为True。
第16~36行代码循环遍历工作表中的表格(不包含汇总表格)。
第17行代码获取表格对象。
第18行代码为表格标识名称(表格对象的Name属性可能不规范,并且和表格在文档中出现的顺序不同,例如Table1在Table2之后)。
第19~35行代码循环遍历数据表格的每行数据。
第20~21行代码从当前行提取关键字。
第22行代码判断两个关键字是否相同。
第23行代码为当前数据行添加书签。
第24行代码判断是否为首个匹配记录,如果是的话,第25行代码将在汇总单元格中插入回车符。
第27行代码在汇总单元格中追加匹配记录信息。
第28行代码获取汇总单元格中的最后一个段落。
第29行代码将段落结束位置向前移动一个字符,即不包含单元格结束标志。
注意:如果没有第29行代码,并且汇总单元格中包含多个段落时,虽然cellRange
为最后一个段落的Range对象,但是第30~32行代码将为第一个段落
设置超链接,听起来似乎不可思议,但是多次测试Word 365就是这个效果。
第30~32行代码为汇总单元格最后一个段落条件超链接。
第33行代码将标识变量设置为False。
下面的自定义函数用于清理Word表格单元格内容,去除不可见字符。
Function GetTxt(sTxt As String) As StringsTxt = Replace(sTxt, Chr(7), "")sTxt = Replace(sTxt, vbCr, "")sTxt = Replace(sTxt, vbLf, "")sTxt = Replace(sTxt, Chr(160), "")GetTxt = Trim(sTxt)
End Function
【代码解析】
第2行代码清除Word表格单元格标志。
第3~4行代码清除回车换行符。
第5行代码清除Word的非间断空格(no-break space,不可见字符)。