如何使用vba实现word选中区域内容快速转表格

Zhanghaijing87

选中区域的内容，包括文本、图片（表格的情况很复杂不考虑了）快速转表格。
已由草莽老师帮忙解决。
万分感谢

Zhanghaijing87

不知道我表达的是否清楚。
就是word中选中的内容专转为表格，标题（不管几级标题）为左边一列，他下面的内容是右边一列。

Zhanghaijing87

Zhanghaijing87 发表于 2024-7-10 09:32
不知道我表达的是否清楚。
就是word中选中的内容专转为表格，标题（不管几级标题）为左边一列，他下面的内 ...

如果太复杂，可以暂时不考虑参数有表格（或者图片）的情况。先能顺利把文本的情况顺利运行。感谢老师们。

zhanglei1371

1. Sub 选定内容转表格_waifa()
   
2. '代码仅供参考,无后续修改服务,不挤面条。有其他需求请自己修改或AI,否则就付费定制！
   
3. Dim rg As Range, rgt As Range, ta As Table, ce As Cell, sha As InlineShape
   
4.     Dim mydoc As Document, pa As Paragraph
   
5.     Set mydoc = ActiveDocument
   
6.     Set rg = Selection.Range
   
7.     Set rgt = rg.Paragraphs.First.Range
   
8.     rgt.InsertBefore vbNewLine
   
9.     Set ta = rgt.Tables.Add(rgt.Paragraphs.First.Range, 1, 2)
   
10.     ta.Columns(1).Width = rgt.Sections(1).PageSetup.TextColumns(1).Width / 3
    
11.     ta.Columns(2).Width = rgt.Sections(1).PageSetup.TextColumns(1).Width * 2 / 3
    
12.     ta.Style = "网格型"
    
13.     ta.Range.Style = "正文"
    
14.     ta.Range.Paragraphs.Last.Next.Range.InsertParagraphBefore
    
15.     rg.Start = ta.Range.End
    
16.     rg.Start = rg.Paragraphs(2).Range.Start
    
17.     Set rgt1 = rg.Paragraphs(1).Range
    
18.     Do
    
19.         If rgt1.End > rg.End Then Exit Do
    
20.         Set rgt1 = rgt1.Paragraphs.Last.Range
    
21.         If rgt1.ParagraphFormat.OutlineLevel < 4 Then
    
22.             If Len(ta.Cell(ta.Rows.Count, 2).Range.Text) > 2 Then ta.Rows.Add
    
23.             ta.Cell(ta.Rows.Count, 1).Range.FormattedText = rgt1
    
24.         Else
    
25.             If rgt1.Information(12) Then
    
26.                 Set rgt1 = rgt1.Tables(1).Range
    
27.                 Set rgt = ActiveDocument.Range(ta.Cell(ta.Rows.Count, 2).Range.End - 1, ta.Cell(ta.Rows.Count, 2).Range.End - 1)
    
28.                 rgt.FormattedText = rgt1
    
29.                 rgt1.Start = ta.Range.Paragraphs.Last.Next.Range.Start
    
30.             Else
    
31.                 Set rgt = ActiveDocument.Range(ta.Cell(ta.Rows.Count, 2).Range.End - 1, ta.Cell(ta.Rows.Count, 2).Range.End - 1)
    
32.                 rgt.FormattedText = rgt1
    
33.             End If
    
34.         End If
    
35.     Loop While rgt1.MoveEnd(4)
    
36.     With ta.Range.ParagraphFormat
    
37.         .Alignment = wdAlignParagraphLeft
    
38.         .CharacterUnitFirstLineIndent = 0
    
39.         .FirstLineIndent = 0
    
40.         .LeftIndent = 0
    
41.     End With
    
42.     rg.Delete
    
43.     MsgBox "OK"
    
44. End Sub

复制代码

Zhanghaijing87

zhanglei1371 发表于 2024-7-11 19:05

感谢张老师、

loquat

没啥好的思路，只能蚂蚁搬家，就不续尾了

1478525

怎么解决的，可以发一下么

Zhanghaijing87

1478525 发表于 2024-7-16 16:53
怎么解决的，可以发一下么

可以问下论坛的蜀中草莽。老师。是他的代码

1478525

Zhanghaijing87 发表于 2024-7-17 14:11
可以问下论坛的蜀中草莽。老师。是他的代码

好的 谢谢