用WORD VBA 定位提取文字，代码如何写，请大师们指教？

13838087988

不只是一个学校呀，从书上输入到EXCEL表格里太慢了，想把复杂的问题简单化，机械的问题自动化。高手在论坛，高手在民间，请老师指教？谢谢

413191246se

楼主，我已经把 微软官方免费的 Word-VBA 帮助文档发给你了，好好学习学习吧！
你说的 三栏文字 变成 一栏文字，录制一个宏就解决了。但关键是怎么找到它。

13838087988

关键是转换后的WORD不是纯文档格式，有的内容是一行一行的纯文档，有的内容在文本框里，还有的是在表里，看上去都是在那个位置，可一旦复制粘贴到EXCEL表里就不霍规则了，现在的问题是怎样把三栏的文字很规律的复制到一个新的文档里，复制后的文档是一栏很规则的纯文字内容，这样复制到EXCEL表里就很规则了，还请老师指教。

413191246se

* 楼主，请重新测试，代码仅供参考。粉红文字为表格文字。六个星号“******”后面的文字取自文本框。

1. Sub DocInfo()
   
2.     With ActiveDocument
   
3.         MsgBox "Pages = " & .ComputeStatistics(wdStatisticPages) & vbCr & _
   
4.             "Characters = " & .ComputeStatistics(wdStatisticCharacters) & vbCr & vbCr & _
   
5.             "Sections = " & .Sections.Count & vbCr & _
   
6.             "Tables = " & .Tables.Count & vbCr & vbCr & _
   
7.             "Shapes = " & .Shapes.Count & vbCr & _
   
8.             "InlineShapes = " & .InlineShapes.Count, 0 + 48, "DocInfo"
   
9.     End With
   
10. End Sub
    
11. 
    
12. Sub a_1128_DeleteShapes_Update()
    
13. '删除图形
    
14.     Dim r As Range, iShape As InlineShape, n&
    
15. 
    
16.     With ActiveDocument
    
17.         .Content.InsertParagraphBefore
    
18. 
    
19.         Set r = .Range(0, .Paragraphs(1).Range.End)
    
20. 
    
21.         For Each iShape In .InlineShapes
    
22.             iShape.Delete
    
23.         Next
    
24. 
    
25.         For n = .Shapes.Count To 1 Step -1
    
26.             With .Shapes(n)
    
27.                 If .TextFrame.HasText <> 0 Then r.InsertBefore Text:=.TextFrame.TextRange.Text
    
28.                 .Delete
    
29.             End With
    
30.         Next
    
31. 
    
32.         .Content.InsertAfter Text:=vbCr & "******" & vbCr & r.Text
    
33.         r.Delete
    
34.     End With
    
35. End Sub
    
36. 
    
37. Sub a_a1128_Cancel_Columns()
    
38. 
    
39.     With ActiveDocument
    
40.         .Fields.Unlink
    
41.         .ConvertNumbersToText
    
42.         .Content.Find.Execute "^l", , , 0, , , , , , "^p", 2
    
43.         
    
44.         Dim t As Table
    
45.         For Each t In .Tables
    
46.             t.Range.Rows.WrapAroundText = False
    
47.             t.Range.Font.ColorIndex = wdPink
    
48.         Next
    
49.         
    
50.         Dim Sec As Section
    
51.         For Each Sec In .Sections
    
52.             Sec.PageSetup.TextColumns.SetCount NumColumns:=1
    
53.         Next
    
54.         
    
55.         .Content.Find.Execute "^12", , , 0, , , , , , "", 2
    
56.         
    
57.         a_1128_DeleteShapes_Update
    
58.         
    
59.         With Selection
    
60.             .HomeKey 6
    
61.             With .Find
    
62.                 .ClearFormatting
    
63.                 .Text = "^13^12"
    
64.                 .Replacement.Text = ""
    
65.                 .Forward = True
    
66.                 .MatchWildcards = True
    
67.                 Do While .Execute
    
68.                     With .Parent
    
69.                         .HomeKey
    
70.                         .Move
    
71.                         .Delete
    
72.                     End With
    
73.                 Loop
    
74.             End With
    
75.         End With
    
76.         
    
77.         With .Content.Find
    
78.             .Execute "^n", , , 0, , , , , , "", 2
    
79.             .Execute "^t", , , 0, , , , , , "", 2
    
80.             .Execute "([ ]@)([0-9]@)", , , 1, , , , , , "^p\2", 2
    
81.         End With
    
82.         
    
83.         For Each t In .Tables
    
84.             With t
    
85.                 .Select
    
86.                 Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:=True
    
87.                 Selection.Find.Execute "^t", , , 0, , , , , , "^p", 2
    
88.             End With
    
89.         Next
    
90.         
    
91.         With .Content.ParagraphFormat
    
92.             .LeftIndent = CentimetersToPoints(0)
    
93.             .RightIndent = CentimetersToPoints(0)
    
94.             .SpaceBefore = 0
    
95.             .SpaceBeforeAuto = False
    
96.             .SpaceAfter = 0
    
97.             .SpaceAfterAuto = False
    
98.             .LineSpacingRule = wdLineSpaceSingle
    
99.             .Alignment = wdAlignParagraphJustify
    
100.             .WidowControl = False
     
101.             .KeepWithNext = False
     
102.             .KeepTogether = False
     
103.             .PageBreakBefore = False
     
104.             .NoLineNumber = False
     
105.             .Hyphenation = True
     
106.             .FirstLineIndent = CentimetersToPoints(0)
     
107.             .OutlineLevel = wdOutlineLevelBodyText
     
108.             .CharacterUnitLeftIndent = 0
     
109.             .CharacterUnitRightIndent = 0
     
110.             .CharacterUnitFirstLineIndent = 0
     
111.             .LineUnitBefore = 0
     
112.             .LineUnitAfter = 0
     
113.             .AutoAdjustRightIndent = False
     
114.             .DisableLineHeightGrid = True
     
115.         End With
     
116.     End With
     
117.    
     
118.     Selection.HomeKey 6
     
119.     DocInfo
     
120. End Sub

复制代码

13838087988

老师的宏代码很好！学生非常感谢。还需要再加上一些控制位置的代码，有个别位置没有处理好，造成了学校的专业错位，还需加上点代码，谢谢老师的指教。王雪峰13838087988

xyxcc177

不需要代码

13838087988

老师转换的也是有错位的，不规范，谢谢老师们的指导。