关于从word文档简提提取文字到Excel表格中的

小青蛙0566

求助我要实现把word里面的简历信息，通过工具提取到excel表格里面来，请问这个是要用代码来实现吗？

还是要写一个小工具来开发出来，请大神帮助，或者有偿加我。

问题现象：把word里面的简历，通过工具来提取到excel表格里面来

3190496160

要提取的项目多达25项，工作量不小，可以加我v

阿诺斯瓦星呆

还好老夫收藏的https://club.excelhome.net/thread-1029709-1-1.html

自己慢慢研究

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1624920&mobile&_dsign=ca4797b9

3190496160

Sub 批量提取()
Application.ScreenUpdating = False
Dim FilePath As String
Dim i As Integer, n As Integer
Dim arr
lj = ThisWorkbook.Path & "\word文档\"
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")   '新建Word对象
WordApp.Visible = True
Dim WordD As Object
f = Dir(lj & "*.doc*")
ReDim arr(1 To 5000, 1 To 26)
Do While f <> ""
    Set WordD = WordApp.Documents.Open(lj & f)
    n = n + 1
    arr(n, 1) = n
    With WordD.tables(1)
        arr(n, 2) = .Cell(2, 2).Range.Text
        arr(n, 3) = .Cell(10, 2).Range.Text
        arr(n, 4) = .Cell(6, 6).Range.Text
        arr(n, 5) = .Cell(2, 4).Range.Text
        arr(n, 6) = .Cell(2, 6).Range.Text
        arr(n, 7) = .Cell(2, 2).Range.Text
        arr(n, 8) = .Cell(3, 2).Range.Text
        arr(n, 9) = .Cell(3, 4).Range.Text
        arr(n, 10) = .Cell(3, 6).Range.Text
        arr(n, 11) = .Cell(4, 2).Range.Text
        Rem 后面的列自己依样画葫芦添加
    End With
    WordD.Close False
f = Dir
Loop
Set WordD = Nothing
WordApp.Quit
Range("a1").CurrentRegion.Offset(2) = Empty
Range("a3").Resize(n, 26) = arr
Range("a3").Resize(n, 26).Select
Selection.Replace What:=Chr(13) & Chr(7), Replacement:="", LookAt:=xlPart
Application.ScreenUpdating = True
MsgBox "完成"
End Sub

3190496160

3190496160

学习强国.rar (313.39 KB, 下载次数: 24)

2023-3-15 11:01 上传

点击文件名下载附件

3190496160

只写了前11列的代码，后面的自己依样画葫芦添加吧

gwjkkkkk

Option Explicit
Sub TEST()
    Dim wdApp As Word.Application, strRngText$
    Dim ar, br, cr, i&, r&, strFileName$, strPath$
   
    Application.ScreenUpdating = False
    On Error Resume Next
    With [A2].CurrentRegion
         .Offset(2).Clear
         ar = .Resize(10 ^ 3)
         r = 2
    End With
    br = [{2,3,4,5,6,8,9,10,11,12,13,14,16,17,18,19,20,21,22,23,24,25,26}]
    cr = [{2,1;10,1;6,5;2,3;2,5;3,1;3,3;3,5;4,1;4,3;4,5;5,1;5,3;5,5;6,1;6,3;7,1;7,3;7,5;8,1;8,4;9,2;9,4}]
   
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.doc*")
    Do Until strFileName = ""
           With wdApp.Documents.Open(strPath & strFileName)
               r = r + 1: ar(r, 1) = r - 2
               With .tables(1)
                    For i = 1 To UBound(br)
                        strRngText = .Cell(cr(i, 1), cr(i, 2)).Range.Text
                        ar(r, br(i)) = Left(strRngText, Len(strRngText) - 2)
                    Next i
               End With
               .Close False
           End With
        strFileName = Dir
    Loop
   
   
    [A1].Resize(r, UBound(ar, 2)) = ar
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。