ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
新浪微博登陆 只需一步, 快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 211|回复: 6
打印 上一主题 下一主题

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

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2017-8-13 22:21 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
内控指引的word文档,如何转为excel问题。 详见附件。
【问题】 参见附件的word文档,VBA如何编码,转为如图所示格式的excel文件,即:“每一条”为一行数据。 可能是多段文字,转为excel中的一行,如第三条是3段文字。 第一列是文档名,第二列是章节。
WORD转excel的问题.zip 31.3 KB, 下载次数: 9
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏1 分享分享 有用有用 无用无用 分享到新浪微博
TA的精华主题TA的得分主题
2
 楼主| 发表于 2017-8-13 22:24 | 只看该作者 |楼主
参见图例,方便不用下载附件,就能明白题目
图例说明.JPG (167.41 KB, 下载次数: 0) 图例说明,方便不用下载附件,就能明白题目
图例说明,方便不用下载附件,就能明白题目
TA的精华主题TA的得分主题
3
发表于 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, 下载次数: 15)

    TA的精华主题TA的得分主题
    4
    发表于 2017-8-14 00:13 | 只看该作者
    happysun1228 发表于 2017-8-13 22:24
    参见图例,方便不用下载附件,就能明白题目

    有正则提取。。。。。。。。。。。。。。。。。。。。。。。。。。。。
    TA的精华主题TA的得分主题
    5
    发表于 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
    TA的精华主题TA的得分主题
    6
     楼主| 发表于 2017-8-14 21:32 | 只看该作者 |楼主
    非常感谢二位,测试成功,正是我要的效果,完美! 拜读学习。
    TA的精华主题TA的得分主题
    7
    发表于 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
    哪里都是正则
    您需要登录后才可以回帖 登录 | 免费注册 新浪微博登陆
    本版积分规则
    关闭

    最新热点上一条 /1 下一条

    关注官方微信,每天坐享新鲜教程
    手机版|关于我们|联系我们|ExcelHome    GMT+8, 2017-11-18 23:32 , Processed in 0.099523 second(s), 21 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优