word表格批量提取指定数据到excel中

xw3141

如何 用vba实现 word表格批量提取指定数据到excel中

zpy2

create temp table aa as   select iif(regexp('^姓  名',字符串),rowid,'') 简历号,regexp2('名~(.+?)~性',字符串,1) 姓名,regexp2('性\s*别~(.)~出生年月',字符串,1) 性别,regexp2('岁.~(\d{4}\.\d{2})~\(',字符串,1) 出生年月,regexp2('民\s*族~(.*?)~',字符串,1) 民族,regexp2('党~时\s*间~(.*?)(?=~参)',字符串,1) 入党年月,regexp2('职务~(.*?)~',字符串,1) 专业技术职务,iif(lag(字符串) over( ) like '简~历',字符串,'') 简历,*  from 正则表达式提取简历内容到表格 where rowid>6; create temp table bb as  select fillna(简历号) 简历号2,* from aa; select row_number() over () 行,group_concat(姓名,'') 姓名,group_concat(性别,'') 性别,group_concat(出生年月,'') 出生年月,group_concat(民族,'') 民族,group_concat(入党年月,'') 入党年月,group_concat(专业技术职务,'') 专业技术职务,group_concat(简历,'') 简历 from bb  group by 简历号2;

洋务德雷

vba可以做，但是工作量较大

smiletwo

zpy2 发表于 2022-4-24 18:49
create temp table aa as   select iif(regexp('^姓  名',字符串),rowid,'') 简历号,regexp2('名~(.+?)~性' ...

请问茄子大神：如何实现手机操作和运行代码的？

xw3141

洋务德雷 发表于 2022-4-24 19:26
vba可以做，但是工作量较大

看了很多资料勉强可以提取
通过循环Tables(i） 来确定 要提取的值 然后逐个写进.Cells(r, 2) = Replace(.Cells(i).Range.Text, Chr(7), "")

xw3141

zpy2 发表于 2022-4-24 18:49
create temp table aa as   select iif(regexp('^姓  名',字符串),rowid,'') 简历号,regexp2('名~(.+?)~性' ...

帮忙看看 能不能优化
Sub 提取word指定数据1()
Dim bgs%
Dim wdcx As Object, wd As Object, ss$
Sheet1.Range("a3:s65536").Clear
Set wdcx = CreateObject("word.application")

ss = Dir(ThisWorkbook.Path & "\要提取的word表\")
Do
    r = Sheet1.[b65536].End(xlUp).Row + 1
     Set wd = wdcx.documents.Open(ThisWorkbook.Path & "\要提取的word表\" & ss)
For i = 1 To wd.Tables.Count
    ff = wd.Tables(i).Range.Cells(1).Range
    If ff Like "姓*名*" Then
        bgs = i
        Exit For
        GoTo 200
        If bgs = 2 Then MsgBox "bgs"
    End If
Next i
200:
    With wd.Tables(bgs).Range
        Sheet1.Cells(r, 1) = ss 'word表名
        Sheet1.Cells(r, 2) = .Cells(2).Range '姓名
        Sheet1.Cells(r, 6) = .Cells(4).Range '性别
        Sheet1.Cells(r, 7) = .Cells(6).Range '出生年月
        Sheet1.Cells(r, 8) = .Cells(9).Range '民族
        Sheet1.Cells(r, 9) = .Cells(11).Range '籍贯
        Sheet1.Cells(r, 10) = .Cells(15).Range '入党时间
        Sheet1.Cells(r, 11) = .Cells(17).Range '参加工作时间
        Sheet1.Cells(r, 12) = .Cells(21).Range '专业技术职务
    End With
    wd.Save
    wd.Close
    n = n + 1
    ss = Dir
Loop Until ss = ""
wdcx.Quit
Set wdcx = Nothing
Set wd = Nothing
MsgBox "共提取" & n & "张word表格"
End Sub

zmj9151

一个小插件....

wang-way

Public Sub wang_way()
    '作者  
    'QQ   
    '日期  2021-02-24
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim doc
    Dim FolderPath, FileName, FilePath
                        
    '连接当前工作簿
    Set Wb = Application.ThisWorkbook
    '获取当前文件夹路径
    FolderPath = Wb.Path & "\"
    '连接工作表1
    Set Sht = Wb.Worksheets(1)
    '清除首行以下的内容
    Sht.UsedRange.Offset(1).Clear
                        
    '初始化行号i
    i = 1
    FileName = Dir(FolderPath & "*.doc*")
    Do While FileName <> ""
        '创建文档路径
        FilePath = FolderPath & FileName
        '打开文档
        Set doc = GetObject(FilePath)
        '每处理一个文件，行号i递增1
        i = i + 1
        '对应关系
        Sht.Cells(i, "A").Value = i - 1 '序号
        '将word第1个表格第1行，第4列的内容写入B列单元格
        Sht.Cells(i, "B").Value = Application.Clean(doc.Tables(1).Cell(1, 4).Range.Text)
        Sht.Cells(i, "C").Value = Application.Clean(doc.Tables(1).Cell(1, 2).Range.Text)
        Sht.Cells(i, "D").Value = Application.Clean(doc.Tables(1).Cell(1, 6).Range.Text)
        Sht.Cells(i, "E").Value = Application.Clean(doc.Tables(1).Cell(1, 8).Range.Text)
        
        c = 6: r = 3
        Sht.Cells(i, c).Value = Application.Clean(doc.Tables(1).Cell(r, 5).Range.Text)
        '之后的数据有明显的对应关系，因此下方代码循环21次
        For n = 1 To 21
            c = c + 1: r = r + 1
            Sht.Cells(i, c).Value = Application.Clean(doc.Tables(1).Cell(r, 5).Range.Text)
        Next n
                                   
        '下一个文件
        FileName = Dir
    Loop
         
                        
    '释放对象
    Set Wb = Nothing
    Set Sht = Nothing
    Set doc = Nothing

    MsgBox "提取完成！"
End Sub

zpy2

smiletwo 发表于 2022-4-24 22:46
请问茄子大神：如何实现手机操作和运行代码的？

分2个模块，
1，是上传 word文件的压缩包，在线解析表格为txt文件。
2，复制内容，粘贴到在线sql运行正则表达式的sql语句。

后台有类似网站支持执行sql。

zpy2

xw3141 发表于 2022-4-25 01:05
看了很多资料勉强可以提取
通过循环Tables(i） 来确定 要提取的值 然后逐个写进.Cells(r, 2) = Replace ...

嗯，提取我也是用正则表达式的，直接从xml提取，速度比较快。
没有用vba。