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

happysun1228 · 发表于 2017-8-13 22:21

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

happysun1228 · 发表于 2017-8-13 22:24

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

weiqigreen · 发表于 2017-8-14 00:12

本帖最后由 weiqigreen 于 2017-8-14 00:13 编辑

Sub 循环遍历段落()
Dim arr
ReDim arr(1 To ActiveDocument.Paragraphs.Count, 1 To 3)
docname = ActiveDocument.Paragraphs(1).Range.Text
cnt = 0
For i = 1 To ActiveDocument.Paragraphs.Count
If ActiveDocument.Paragraphs(i).Range.Font.Size = 22 Then '如果字号是22则是文档名
docname = ActiveDocument.Paragraphs(i).Range.Text
Else
contents = ActiveDocument.Paragraphs(i).Range.Text
temp = Left(contents, 10)
If InStr(1, temp, "第") * InStr(1, temp, "章") <> 0 Then
zhangName = contents
ElseIf InStr(1, temp, "第") * InStr(1, temp, "条") <> 0 Then
cnt = cnt + 1
arr(cnt, 3) = contents
arr(cnt, 2) = zhangName
arr(cnt, 1) = docname
Else
arr(cnt, 3) = arr(cnt, 3) & Chr(10) & Chr(13) & contents
End If
End If
Next
Set exl = CreateObject("excel.application")
With exl
.Workbooks.Add
.sheets("sheet1").[a1].Resize(1, 3) = Array("文档名", "第几章", "第几条")
.sheets("sheet1").[a2].Resize(UBound(arr), UBound(arr, 2)) = arr
.activeworkbook.SaveAs ActiveDocument.Path & "\转换后的文档.xlsx"
.Quit
End With
Set exl = Nothing
End Sub

复制代码

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

duquancai · 发表于 2017-8-14 00:13

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

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

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 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 · 发表于 2017-8-14 21:32

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

loquat · 发表于 2017-8-15 11:09

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
哪里都是正则

		自动登录	找回密码
密码			免费注册

[求助] 内控指引的word文档，如何转为excel文件