批量从word中提取标题和内容放到excel中

sillyrabbit

急，求大神

ming0018

sillyrabbit 发表于 2018-6-5 21:06
急，求大神

有多急？可以私聊。

sillyrabbit

ming0018 发表于 2018-6-6 08:29
有多急？可以私聊。

怎么私聊呢

duquancai

sillyrabbit 发表于 2018-6-5 16:52
花钱也可以奥

既然是在Word板块的帖子，我就用WordVBA写个代码！

1. Sub main()
   
2.     Dim myDaTa(), doc As Document, pf$, xlapp As Object
   
3.     Set doc = ActiveDocument
   
4.     ReDim myDaTa(1 To 1, 1 To 2)
   
5.     Call GetDaTa(doc, myDaTa)
   
6.     pf = doc.Path & "\文档2.xlsx"
   
7.     Set xlapp = CreateObject("Excel.Application")
   
8.     xlapp.Visible = True
   
9.     With xlapp.Workbooks.Open(pf)
   
10.         .sheets(1).Cells.Clear
    
11.         .sheets(1).[a1] = "标题": .sheets(1).[b1] = "内容"
    
12.         .sheets(1).Range("a2").Resize(UBound(myDaTa), 2) = myDaTa
    
13.     End With
    
14.     MsgBox "OK!"
    
15. End Sub
    
16. Sub GetDaTa(thisdoc As Document, ByRef p)
    
17.     Dim ar(), n&, i&
    
18.     With thisdoc.Range.Find
    
19.         .ParagraphFormat.OutlineLevel = 1
    
20.         Do While .Execute
    
21.             With .Parent
    
22.                 n = n + 1: ReDim Preserve ar(n)
    
23.                 ar(n - 1) = .Start: .Start = .End
    
24.             End With
    
25.         Loop
    
26.     End With
    
27.     ar(n) = thisdoc.Range.End: ReDim p(1 To n, 1 To 2)
    
28.     For i = 1 To n
    
29.         With thisdoc.Range(ar(i - 1), ar(i))
    
30.             p(i, 1) = .Paragraphs(1).Range.Text
    
31.             .MoveStart 4, 1
    
32.             p(i, 2) = .Text
    
33.         End With
    
34.     Next
    
35. End Sub

复制代码

sillyrabbit

duquancai 发表于 2018-6-8 01:01
既然是在Word板块的帖子，我就用WordVBA写个代码！

不行吧，出现错误啊

duquancai

sillyrabbit 发表于 2018-6-10 15:58
不行吧，出现错误啊

我的行，还有其他人也没说不行。就你说不行吧（语气还不肯定）！

sillyrabbit

duquancai 发表于 2018-6-10 17:00
我的行，还有其他人也没说不行。就你说不行吧（语气还不肯定）！

报错了，直接复制进去就行是么。我的真的报错了。

sillyrabbit

duquancai 发表于 2018-6-10 17:00
我的行，还有其他人也没说不行。就你说不行吧（语气还不肯定）！

报错了，直接复制进去就行是么。我的真的报错了。

daibao88

还没有人说杜大神的代码不行
居然连句谢谢都没有

zhouxl2000

先同目录下新建“文档2.xlsx”，测试完美通过