excel在不同excel的文档中固定位置提取数据 急需

zpy2

zpli111 发表于 2023-6-13 10:20
每周几百封类似的邮件，怎么快速合并在一起汇总处理。
结果如下：
最右边列显示产品型号，标题是交期， ...

https://club.excelhome.net/forum.php?mod=viewthread&tid=1663330&mobile
你pdf是咋提取的？

zpy2

zpli111 发表于 2023-6-13 10:20
每周几百封类似的邮件，怎么快速合并在一起汇总处理。
结果如下：
最右边列显示产品型号，标题是交期， ...

https://club.excelhome.net/forum.php?mod=viewthread&tid=1664606&mobile=
Excel可以多表合并后用正则表达式提取

zpy2

zpy2 发表于 2023-6-13 21:45
https://club.excelhome.net/forum.php?mod=viewthread&tid=1664606&mobile=
Excel可以多表合并后用正则 ...

create temp table aa as
select  fillna(regexp2('^物料.*',f04)) 物料,regexp2('[WM]\s\d\d\.\d{4}|D\s\d{2}\.\d{2}\.\d{4}',f04) 要求到货日期,f06 数量 from consolidateSheet ;
select udf_clean_rpt_ent(物料,'k') 物料, 要求到货日期,数量 from aa where 要求到货日期!='';

pxy0409

zpli111 发表于 2023-6-13 10:20
每周几百封类似的邮件，怎么快速合并在一起汇总处理。
结果如下：
最右边列显示产品型号，标题是交期， ...

附件中模拟了10个文件,几百个的话,刚才模拟了320个文件,刷新速度大概不到10秒,还可以吧!

sosomc

zpli111 发表于 2023-6-13 10:13
指点下，谢谢！

新建一个把代码放进去


Sub getworkbooksB()
'指定固定文件夹导入
Dim mydir
Dim Ws As Worksheet
Dim thiswb As Workbook
Const fd = "D:\下载待分类\文件1\文件\原始数据"
Dim i&, j&, m&
Dim arr, brr
Dim temp$, temp1$
    Call 禁止
    On Error Resume Next

    Set thiswb = ThisWorkbook

    'fd = "C:\Users\ZY86385\Desktop\all"
    'fd = Worksheets("Menu").[s2].Value
    ReDim arr(m)
    arr(m) = Array("型号", "交期", "数量", "所在工作表")
   
    mydir = fd & "\"
    fname = Dir(fd & "\*.xls*")
   
    Do Until fname = ""
        Set wkb = Workbooks.Open(Filename:=fd & "\" & fname)
        For Each Ws In wkb.Worksheets
            brr = Ws.UsedRange
            For i = 1 To UBound(brr)
                If brr(i, 2) Like "物料*" Then temp = brr(i, 2): temp1 = wkb.Name & "|" & Ws.Name
                If brr(i, 2) Like "[A-Z] #*" Then
                    m = m + 1
                    ReDim Preserve arr(m)
                    arr(m) = Array(temp, brr(i, 2), brr(i, 4), temp1)
                End If
            Next
            
        Next
        wkb.Close False
        fname = Dir()
    Loop
   
'    MsgBox (CStr(fd) & "下Excel文件导入完成！")
   
    Set Ws = Nothing
    Set fname = Nothing
    Set thiswb = Nothing
   
    Sheets(1).Select
    Sheets(1).Rows.Clear
    ReDim brr(m, 1 To 4)
    For i = 0 To m
    For j = 1 To 4
        brr(i, j) = arr(i)(j - 1)
        
    Next
    Next
    For i = m To 1 Step -1
        If brr(i, 1) = brr(i - 1, 1) Then brr(i, 1) = ""
    Next
   
    [a1].Resize(m, 4) = brr
   
    Erase arr
    Erase brr
    Call 恢复
End Sub
Sub 禁止()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
End Sub

Sub 恢复()
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub

sosomc

试试吧   把路径自己改一改