[分享VBA]续表

konggs

功能：表格转页时，在第一行出现续表一的字样。 一个很不好的解决方法。前段时间做的（准备删了，），放上来，给大家抛砖引玉吧 Sub 孤独一叶() Dim a%, b%, c%, i%, atable As Table, d%, e% On Error Resume Next '忽略错误 Application.ScreenUpdating = False '屏幕不更新 For Each atable In ActiveDocument.Tables e = e + 1 a = atable.Range.Cells.Count '取得单元格数 b = atable.Columns.Count '取得列数 c = atable.Rows.Count '取得行数 If atable.Range.Cells(1).Range.Information(wdActiveEndPageNumber) <> _ atable.Range.Cells(a).Range.Information(wdActiveEndPageNumber) Then For i = 1 To a With atable.Range If .Cells(1).Range.Information(wdActiveEndPageNumber) <> _ .Cells(1 + i).Range.Information(wdActiveEndPageNumber) Then .Cells(1 + i).Range.Text = "续表" & e .Cells(1 + i).Merge mergeto:=.Cells(1 + i + b - 1) With .Cells(1 + i) .Borders(wdBorderLeft).LineStyle = wdLineStyleNone .Borders(wdBorderRight).LineStyle = wdLineStyleNone ' .Borders(wdBorderTop).LineStyle = wdLineStyleNone End With If .Cells(1 + i + d).Range.Information(wdFirstCharacterLineNumber) <> _ .Cells(1 + i + d + 1).Range.Information(wdFirstCharacterLineNumber) Then For d = 1 To b '取得第二行的单元格内容 '要求第一行为合并行，第二条像这样的行：姓名，年龄，等 .Cells(1 + i + d).Range.Text = Left(.Cells(1 + d).Range.Text, Len(.Cells(1 + d).Range.Text) - 2) Next Else For d = 1 To b '取得第二行的单元格内容 '要求第一行不为合并行，则第二行像这样的行：姓名，年龄，等 .Cells(1 + i + d).Range.Text = Left(.Cells(b + d).Range.Text, Len(.Cells(b + d).Range.Text) - 2) Next End If Exit For End If End With Next With Selection.Tables(1).Range.Cells(1).Borders ' .InsideLineStyle = wdLineStyleNone End With 'atable.Range.Cells(1).Range.Text = "续表" End If Next Application.ScreenUpdating = True '屏幕更新 End Sub

守柔

感谢KONGGS兄的代码。

去年我也曾做过一个（比较简陋），正如孔兄所言，并非真正解决之道。一并拿出来，希望对大家有所帮助。

Sub Example()
Dim myTable As Table, oRow As Row, myRow As Row
Dim KeyText As String
KeyText = "接续上表"
Application.ScreenUpdating = False
Set myTable = Selection.Tables(1)
For Each oRow In myTable.Rows
If VBA.InStr(oRow.Range, KeyText) = 1 Then oRow.Delete
Next
Set myTable = Selection.Tables(1)
For Each oRow In myTable.Rows
If oRow.IsFirst = True Then GoTo GN
If oRow.Range.Information(wdActiveEndPageNumber) <> oRow.Previous.Range.Information(wdActiveEndPageNumber) Then
Set myRow = myTable.Rows.Add(oRow)
With myRow
.Cells.Merge
.Range.Text = KeyText
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
End With
End If
GN: Next
Application.ScreenUpdating = True
End Sub

konggs

谢谢老大,

老大的比我简洁多了,也快多了.

chenhuafu

 "接续上表"
这个能不能更加智能化一点。如果表的编号是采用  插入－> 题注 的方法插入，则应该是可以通过代码自动找到这个  编号，那么，接续上表  的这个字符串就可以用    "接" & 变量 & "表"   整个字符串来表达。由于我只对 Excel 的 VBA 有多了解，对 Word 的 VBA 还没有深入学习。

所以，只能提出意见，完善的方法。而不能修改老大的代码。

这个代码我收藏了，以后有机会好好学一下 Word 的 VBA 。

chendeyan126

守柔 发表于 2006-4-29 06:45
感谢KONGGS兄的代码。
去年我也曾做过一个（比较简陋），正如孔兄所言，并非真正解决之道。一并拿出来，希 ...

非常感谢，好用！