内控指引的word文档，如何转为excel文件

happysun1228

内控指引的word文档，如何转为excel问题。 详见附件。
【问题】 参见附件的word文档，VBA如何编码，转为如图所示格式的excel文件，即：“每一条”为一行数据。 可能是多段文字，转为excel中的一行，如第三条是3段文字。 第一列是文档名，第二列是章节。

happysun1228

参见图例，方便不用下载附件，就能明白题目

weiqigreen

1. Sub 循环遍历段落()
   
2.     Dim arr
   
3.     ReDim arr(1 To ActiveDocument.Paragraphs.Count, 1 To 3)
   
4.     docname = ActiveDocument.Paragraphs(1).Range.Text
   
5.     cnt = 0
   
6.     For i = 1 To ActiveDocument.Paragraphs.Count
   
7.         If ActiveDocument.Paragraphs(i).Range.Font.Size = 22 Then '如果字号是22则是文档名
   
8.             docname = ActiveDocument.Paragraphs(i).Range.Text
   
9.         Else
   
10.             contents = ActiveDocument.Paragraphs(i).Range.Text
    
11.             temp = Left(contents, 10)
    
12.             If InStr(1, temp, "第") * InStr(1, temp, "章") <> 0 Then
    
13.                 zhangName = contents
    
14.             ElseIf InStr(1, temp, "第") * InStr(1, temp, "条") <> 0 Then
    
15.                 cnt = cnt + 1
    
16.                 arr(cnt, 3) = contents
    
17.                 arr(cnt, 2) = zhangName
    
18.                 arr(cnt, 1) = docname
    
19.             Else
    
20.                 arr(cnt, 3) = arr(cnt, 3) & Chr(10) & Chr(13) & contents
    
21.             End If
    
22.         End If
    
23.     Next
    
24.    
    
25.     Set exl = CreateObject("excel.application")
    
26.     With exl
    
27.     .Workbooks.Add
    
28.     .sheets("sheet1").[a1].Resize(1, 3) = Array("文档名", "第几章", "第几条")
    
29.     .sheets("sheet1").[a2].Resize(UBound(arr), UBound(arr, 2)) = arr
    
30.     .activeworkbook.SaveAs ActiveDocument.Path & "\转换后的文档.xlsx"
    
31.     .Quit
    
32.     End With
    
33.     Set exl = Nothing
    
34. 
    
35. End Sub
    

复制代码

修改后的_WORD转excel的问题.rar (15.61 KB, 下载次数: 21)

2017-8-14 00:13 上传

点击文件名下载附件

duquancai

happysun1228 发表于 2017-8-13 22:24
参见图例，方便不用下载附件，就能明白题目

有正则提取。。。。。。。。。。。。。。。。。。。。。。。。。。。。

duquancai

Sub shishi()
    Dim doc As Document, p As Range, s As Range, f1$, f2$
    Dim strarr(1 To 1000, 1 To 3), mt, reg As Object
    Set doc = ActiveDocument
    Set p = doc.Content: rg = "[〇一二三四五六七八九十百千万]"
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    reg.Pattern = "^第" & rg & "+条(?:(?!^第" & rg & "+条).)+"
    f1 = "标题 1": f2 = "副标题"
    a = Spa(doc, p, f1)
    For i = 0 To UBound(a, 2)
        S1 = a(1, i): Set s = a(0, i)
        b = Spa(doc, s, f2)
        For j = 0 To UBound(b, 2)
            S2 = b(1, j): sr = b(0, j)
            For Each mt In reg.Execute(sr)
                x = x + 1
                strarr(x, 1) = S1
                strarr(x, 2) = S2
                strarr(x, 3) = mt
            Next
        Next
    Next
    If Tasks.Exists("Microsoft Excel") Then
        Set xlapp = GetObject(, "excel.application")
    Else
        Set xlapp = CreateObject("Excel.Application")
    End If
    Set myBook = xlapp.Workbooks.Add: xlapp.Visible = True
    Set mysheet = myBook.Worksheets("sheet1"): mysheet.Activate
    mysheet.Range("a1:c1") = Array("文档名", "第几章", "第几条")
    mysheet.Range("a2").Resize(x, 3) = strarr
End Sub
Function Spa(doc As Document, p As Range, fr As String)
    Dim myStart&, n&, arr(), s As Range
    Set s = p.Duplicate
    With s.Find
        .Style = fr
        Do While .Execute
            If Not s.InRange(p) Then Exit Do
            n = n + 1
            ReDim Preserve arr(1, n - 1)
            With s
                If n > 1 Then
                    Set arr(0, n - 2) = doc.Range(myStart, .Start)
                    Set arr(1, n - 2) = doc.Range(myStart, .Start).Paragraphs(1).Range
                End If
                myStart = .Start: .SetRange .End, .End
            End With
        Loop
        If n > 0 Then
            Set arr(0, n - 1) = doc.Range(myStart, p.End)
            Set arr(1, n - 1) = doc.Range(myStart, p.End).Paragraphs(1).Range
        End If
    End With
    Spa = arr
End Function

happysun1228

非常感谢二位，测试成功，正是我要的效果，完美！ 拜读学习。

loquat

duquancai 发表于 2017-8-14 09:23
Sub shishi()
    Dim doc As Document, p As Range, s As Range, f1$, f2$
    Dim strarr(1 To 1000, 1 ...

阿杜案例都是 shishi
哪里都是正则