跪求把word的数字和文字分别提取到excel【已解决】

412804771

如题，领导从健身房搞来一份名单，是word格式的，要我把名字和电话提取出来，整理到excel表格中好导入通讯录，除了一个个复制粘贴外不知道还有没有简单的办法，求坛里的大神支支招，可以留下支付宝请你喝汽水，附件是文档的一页内容，因为涉及到隐私问题改过部分数字，其他页都是一样的格式

已经用分列工具完美转换，谢谢大家的热心帮助，其他方法没有试，汽水先到先得，再次感谢

vs2010

存成txt，导入excel

jiny680p

直接拷贝到Excel。使用分列工具转为Excel表文件。

名单1.zip (11.41 KB, 下载次数: 31)

2016-6-24 22:09 上传

点击文件名下载附件

gbgbxgb

内容有误，删除。

duquancai

请把以下代码放入需要提取的Word文档VBE中执行，请测试：
Sub WordtoExdel()
    Dim strRng As Range
    Dim myBook As Object
    Dim mysheet As Object
    Dim RegMatch
    Dim n As Long
    Dim arrData()
   
    With CreateObject("VBScript.Regexp")
        Set strRng = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
        .Global = True
        .Pattern = "([一-﨩]{2,5})(?=;[男女])[^\r]+(\d{11})(?!\d)"
        ReDim arrData(1 To .Execute(strRng).Count, 1 To 2)
        For Each RegMatch In .Execute(strRng)
            n = n + 1
            arrData(n, 1) = RegMatch.submatches(0)
            arrData(n, 2) = "'" & RegMatch.submatches(1)
        Next
    End With
   
    With CreateObject("Excel.Application")
        If Tasks.Exists("Microsoft Excel") = True Then Tasks("Microsoft Excel").Close
        Set myBook = .Workbooks.Add: .Visible = True
        Set mysheet = myBook.Worksheets("sheet1"): mysheet.Activate
        mysheet.Range("a1:b1") = Array("姓名", "手机号码")
        mysheet.Range("a2").Resize(n, 2) = arrData
    End With
   
    Set RegMatch = Nothing: Set strRng = Nothing
    Set myBook = Nothing: Set mysheet = Nothing
End Sub

412804771

jiny680p 发表于 2016-6-24 22:09
直接拷贝到Excel。使用分列工具转为Excel表文件。

原来用分列工具就可以了，测试了一下简单方便，而且内容齐全，非常感谢，留下支付宝，汽水是你的

jiny680p

412804771 发表于 2016-6-25 15:14
原来用分列工具就可以了，测试了一下简单方便，而且内容齐全，非常感谢，留下支付宝，汽水是你的

不用啦～原数据很规整。注意格式，身份证等要用文本。

duquancai

412804771 发表于 2016-6-25 15:14
原来用分列工具就可以了，测试了一下简单方便，而且内容齐全，非常感谢，留下支付宝，汽水是你的

4楼高级的东西你不用，把汽水给别人!哈哈哈！