求助，VB怎么把word里面的纵向合并单元格提取并插入到新的表格中

tamyuk

因为最近有大量的word文件需要复制粘帖。每个文件名称有个前缀，因为生产环境只能用VB，所以想通过VB实现自动识别对应文件然后复制粘帖，但是实现的过程中发现纵向合并单元格无法操作，请各位大神指点一下。
我简单精简一下需求，我想要实现的功能是：
在图中的“表格1”中，识别到内容含“TTitle11”所在的“行”（包含合并的）需要注意的是TTitle所在的行是不确定的，可能是第一行可能是第十行，然后提取出来，如图中的第二个表格：提取内容
然后把”提取内容“插入/合并到“新表格中”，即图中 最后一个表格的那样，我发现我每次都提示错误5991，因为包含纵向合并单元格



又或者，把“表格1”中的含“TTittle11”所在行的内容（即图中第二个表格的内容）提取到excel中，形成
这样的表格
不管哪个办法，我都提示错误5991了

tamyuk

不小心放多图片了，怎么编辑帖子啊

taller

taller

1. Sub Demo()
   
2.     Dim t As Table, c As Cell, Col1 As Range
   
3.     Dim txt As String, bFound As Boolean
   
4.     Set t = ActiveDocument.Tables(1)
   
5.     For Each c In t.Range.Cells
   
6.         If c.ColumnIndex = 1 Then
   
7.         txt = c.Range.Text
   
8.         txt = Left(txt, Len(txt) - 2)
   
9.         If txt = "Title11" Then
   
10.             c.Range.Select
    
11.             Selection.MoveDown Unit:=wdLine, Count:=1
    
12.             Selection.Start = c.Range.Start
    
13.             Selection.Copy
    
14.             bFound = True
    
15.             Exit For
    
16.         End If
    
17.         End If
    
18.     Next
    
19.     If bFound Then
    
20.         With ActiveDocument.Tables(2)
    
21.             Dim rCnt: rCnt = .Rows.Count
    
22.             .Columns(1).Cells(3).Select
    
23.             Selection.Rows.Delete
    
24.             Selection.PasteAndFormat wdFormatOriginalFormatting
    
25.         End With
    
26.     End If
    
27. End Sub

复制代码

tamyuk

taller 发表于 2024-11-16 03:02

太感谢了！！！

tamyuk

taller 发表于 2024-11-16 03:02

如果我的目标表格也包含了纵向合并单元格的话呢

比如这样，

tamyuk

taller 发表于 2024-11-16 03:02

差一步了，怎么在下面插入而不是第一格

taller

1. ' 使用类似方法定位第二个表格中的单元格（假设内容为Title11）
   
2. Sub Demo()
   
3.     Dim t As Table, c As Cell, Col1 As Range
   
4.     Dim txt As String, bFound As Boolean
   
5.     Set t = ActiveDocument.Tables(1)
   
6.     For Each c In t.Range.Cells
   
7.         If c.ColumnIndex = 1 Then
   
8.             txt = c.Range.Text
   
9.             txt = Left(txt, Len(txt) - 2)
   
10.             If txt = "Title11" Then
    
11.                 c.Range.Select
    
12.                 Selection.MoveDown Unit:=wdLine, Count:=1
    
13.                 Selection.Start = c.Range.Start
    
14.                 Selection.Copy
    
15.                 bFound = True
    
16.                 Exit For
    
17.             End If
    
18.         End If
    
19.     Next
    
20.     If bFound Then
    
21.         With ActiveDocument.Tables(2)
    
22.             For Each c In .Range.Cells
    
23.                 If c.ColumnIndex = 1 Then
    
24.                     txt = c.Range.Text
    
25.                     txt = Left(txt, Len(txt) - 2)
    
26.                     If txt = "Title11" Then
    
27.                         c.Range.Select
    
28.                         c.Delete ShiftCells:=wdDeleteCellsEntireRow
    
29.                         Selection.PasteAndFormat wdFormatOriginalFormatting
    
30.                         Exit For
    
31.                     End If
    
32.                 End If
    
33.             Next
    
34.         End With
    
35.     End If
    
36. End Sub
    

复制代码