把用刀明细工作簿的数据按日期条件提取到汇总表中

小白兔3399

大家好：
我有《用刀明细（一仓）》，《用刀明细（二仓）》，《用刀汇总》 三个工作簿

想实现以下功能：
点击《用刀汇总》表中的”汇总“命令按扭，在不打开用刀明细工作簿的情况下，自动把用刀明细工作簿中的符合条件的数据提取过来，
详细见附表。感谢帮忙！ 新建文件夹 (4).zip (47.48 KB, 下载次数: 12)

2020-6-6 21:44 上传

点击文件名下载附件

sheffield

请试一下附件。如果不想打开数据来源工作簿，需要保持他们和汇总表在同一目录下。代码如：

1. Sub main()
   
2.     Dim criteria, destination As Worksheet, d_row As Long
   
3.     Dim flow_source As Object
   
4.     '汇总目的地：
   
5.     Set destination = ThisWorkbook.Sheets("用刀明细")
   
6.     d_row = 3
   
7.     '检索关键字：
   
8.     criteria = Format(destination.Cells(2, 15), "yyyymmdd")
   
9.     '检索字段：
   
10.     Set flow_source = CreateObject("Scripting.Dictionary")
    
11.     flow_source("用刀明细（一仓）?换刀") = "领刀日期,产品名称:刀号,料号2 As 刀具料号,领刀数量:品牌,            生产数量,            预计寿命,其他 As 备注,换刀~'' As 类别, 一仓~'' As 仓位,新刀~'' As 刀具属性"
    
12.     flow_source("用刀明细（一仓）?架机") = "领刀日期,产品名称:刀号,料号  As 刀具料号,领刀数量:品牌,EMPTY~'' As 生产数量,EMPTY~'' As 预计寿命,        备注,架机~'' As 类别, 一仓~'' As 仓位,新刀~'' As 刀具属性"
    
13.     flow_source("用刀明细（二仓）?换刀") = Replace(flow_source("用刀明细（一仓）?换刀"), "一仓", "二仓")
    
14.     flow_source("用刀明细（二仓）?架机") = Replace(flow_source("用刀明细（一仓）?架机"), "一仓", "二仓")
    
15.     '执行ExcelSpice工作流：
    
16.     For Each s In flow_source
    
17.         spice_work_flow criteria, s, flow_source(s), destination, d_row
    
18.     Next
    
19.     '修改个别标志
    
20.     With destination
    
21.         For i = 3 To d_row
    
22.             If .Cells(i, 8) Like "*返修*" Then .Cells(i, 14) = "返修刀"
    
23.         Next
    
24.     End With
    
25. End Sub
    
26. 
    
27. Sub spice_work_flow(ByVal criteria, ByVal source, ByVal fields As String, destination As Worksheet, ByRef d_row As Long)
    
28.     On Error Resume Next
    
29.     Dim sp As New ExcelSpice
    
30.     '连接数据源、检索、输出：
    
31.     sp.Link source, Index:="领刀日期"
    
32.     Set sp = sp.Some(What:=fields, Index:=criteria)
    
33.     sp.push sp.Records, destination.Cells(d_row, 1)
    
34.     '首次输出时输出标题
    
35.     If d_row = 3 Then sp.push sp.Header, destination.Cells(2, 1)
    
36.     d_row = d_row + sp.Length + 1
    
37.     If Err.Number Then d_row = d_row - 1: Err.Number = 0
    
38. End Sub

复制代码

关于修改个别标志的问题，本来excelspice也能做到，但是在连续检索不同表格时会因为报错而中断，下一版本会修复，请使用最新版ExcelSpice。
http://club.excelhome.net/thread-1540656-1-1.html

sheffield

Sub main()
    Dim criteria, destination As Worksheet, d_row As Long
    Dim flow_source As Object
    '汇总目的地：
    Set destination = ThisWorkbook.Sheets("用刀明细")
    d_row = 3
    '检索关键字：
    criteria = Format(destination.Cells(2, 15), "yyyymmdd")
    '检索字段：
    Set flow_source = CreateObject("Scripting.Dictionary")
    flow_source("用刀明细（一仓）?换刀") = "领刀日期,产品名称:刀号,料号2 As 刀具料号,领刀数量:品牌,            生产数量,            预计寿命,其他 As 备注,换刀~'' As 类别, 一仓~'' As 仓位,新刀~'' As 刀具属性"
    flow_source("用刀明细（一仓）?架机") = "领刀日期,产品名称:刀号,料号  As 刀具料号,领刀数量:品牌,EMPTY~'' As 生产数量,EMPTY~'' As 预计寿命,        备注,架机~'' As 类别, 一仓~'' As 仓位,新刀~'' As 刀具属性"
    flow_source("用刀明细（二仓）?换刀") = Replace(flow_source("用刀明细（一仓）?换刀"), "一仓", "二仓")
    flow_source("用刀明细（二仓）?架机") = Replace(flow_source("用刀明细（一仓）?架机"), "一仓", "二仓")
    '执行ExcelSpice工作流：
    For Each s In flow_source
        spice_work_flow criteria, s, flow_source(s), destination, d_row
    Next
    '修改个别标志
    With destination
        For i = 3 To d_row
            If .Cells(i, 8) Like "*返修*" Then .Cells(i, 14) = "返修刀"
        Next
    End With
End Sub

Sub spice_work_flow(ByVal criteria, ByVal source, ByVal fields As String, destination As Worksheet, ByRef d_row As Long)
    On Error Resume Next
    Dim sp As New ExcelSpice
    '连接数据源、检索、输出：
    sp.Link source, Index:="领刀日期"
    Set sp = sp.Some(What:=fields, Index:=criteria)
    sp.push sp.Records, destination.Cells(d_row, 1)
    '首次输出时输出标题
    If d_row = 3 Then sp.push sp.Header, destination.Cells(2, 1)
    d_row = d_row + sp.Length + 1
    If Err.Number Then d_row = d_row - 1: Err.Number = 0
End Sub

sheffield

Sub main()     Dim criteria, destination As Worksheet, d_row As Long     Dim flow_source As Object     '汇总目的地：     Set destination = ThisWorkbook.Sheets("用刀明细")     d_row = 3     '检索关键字：     criteria = Format(destination.Cells(2, 15), "yyyymmdd")     '检索字段：     Set flow_source = CreateObject("Scripting.Dictionary")     flow_source("用刀明细（一仓）?换刀") = "领刀日期,产品名称:刀号,料号2 As 刀具料号,领刀数量:品牌,            生产数量,            预计寿命,其他 As 备注,换刀~'' As 类别, 一仓~'' As 仓位,新刀~'' As 刀具属性"     flow_source("用刀明细（一仓）?架机") = "领刀日期,产品名称:刀号,料号  As 刀具料号,领刀数量:品牌,EMPTY~'' As 生产数量,EMPTY~'' As 预计寿命,        备注,架机~'' As 类别, 一仓~'' As 仓位,新刀~'' As 刀具属性"     flow_source("用刀明细（二仓）?换刀") = Replace(flow_source("用刀明细（一仓）?换刀"), "一仓", "二仓")     flow_source("用刀明细（二仓）?架机") = Replace(flow_source("用刀明细（一仓）?架机"), "一仓", "二仓")     '执行ExcelSpice工作流：     For Each s In flow_source         spice_work_flow criteria, s, flow_source(s), destination, d_row     Next     '修改个别标志     With destination         For i = 3 To d_row             If .Cells(i, 8) Like "*返修*" Then .Cells(i, 14) = "返修刀"         Next     End With End Sub  Sub spice_work_flow(ByVal criteria, ByVal source, ByVal fields As String, destination As Worksheet, ByRef d_row As Long)     On Error Resume Next     Dim sp As New ExcelSpice     '连接数据源、检索、输出：     sp.Link source, Index:="领刀日期"     Set sp = sp.Some(What:=fields, Index:=criteria)     sp.push sp.Records, destination.Cells(d_row, 1)     '首次输出时输出标题     If d_row = 3 Then sp.push sp.Header, destination.Cells(2, 1)     d_row = d_row + sp.Length + 1     If Err.Number Then d_row = d_row - 1: Err.Number = 0 End Sub

3190496160

这个问题不难，但是，由于两个表中的字段位置不一致，所以，代码很繁琐，排序没有弄，先看看这个是不是你需要额效果再说吧
Sub hz()
Application.ScreenUpdating = False
Set sht = ThisWorkbook.Worksheets("用刀明细")
sht.[a1].CurrentRegion.Offset(2) = Empty
rq = sht.[o2]
f = Dir(ThisWorkbook.Path & "\用刀明细\*.xls*")
ReDim arr(1 To 10000, 1 To 14)
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\用刀明细\" & f, 0)
        cw = Replace(Split(wb.Name, "）")(0), "用刀明细（", "")
            For Each sh In wb.Worksheets
                ar = sh.Range("a1").CurrentRegion
                If sh.Name = "换刀" Then
                    mc = 3
                    lh = 14
                    gx = 4
                    dh = 5
                    sl = 7
                    yy = 8
                    pp = 9
                ElseIf sh.Name = "架机" Then
                    mc = 4
                    lh = 7
                    gx = 5
                    dh = 6
                    sl = 9
                    yy = 10
                    pp = 11
                End If
               
                For i = 6 To UBound(ar)
                    If IsDate(ar(i, 1)) Then
                        If DateValue(ar(i, 1)) = DateValue(rq) Then
                            n = n + 1
                            arr(n, 1) = ar(i, 1)
                            arr(n, 2) = ar(i, mc)
                            arr(n, 3) = ar(i, gx)
                            arr(n, 4) = ar(i, dh)
                            arr(n, 5) = ar(i, lh)
                            arr(n, 6) = ar(i, sl)
                            arr(n, 7) = ar(i, yy)
                            arr(n, 8) = ar(i, pp)
                            If sh.Name = "换刀" Then
                                arr(n, 9) = ar(i, 11)
                                arr(n, 10) = ar(i, 12)
                            Else
                                arr(n, 9) = ""
                                arr(n, 10) = ""
                            End If
                            If sh.Name = "架机" Then
                                arr(n, 11) = ar(i, 12)
                            Else
                                arr(n, 11) = ""
                            End If
                            arr(n, 12) = sh.Name
                            arr(n, 13) = cw
                            If InStr(arr(n, 8), "返修") > 0 Then
                                arr(n, 14) = "返修"
                            Else
                                arr(n, 14) = "新刀"
                            End If
                        End If
                    End If
                Next i
            Next sh
        wb.Close False
    End If
f = Dir
Loop
sht.[a3].Resize(n, UBound(arr, 2)) = arr
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

小白兔3399

3190496160 发表于 2020-6-7 12:11
这个问题不难，但是，由于两个表中的字段位置不一致，所以，代码很繁琐，排序没有弄，先看看这个是不是你需 ...

代码停在这个地方就不动了
sht.[a3].Resize(n, UBound(arr, 2)) = arr

小白兔3399

sheffield 发表于 2020-6-7 11:35
请试一下附件。如果不想打开数据来源工作簿，需要保持他们和汇总表在同一目录下。代码如：关于修改个别标志 ...

代码停在以下这个地方就不动了
spice_work_flow criteria, s, flow_source(s), destination, d_row

sheffield

小白兔3399 发表于 2020-6-7 16:31
代码停在以下这个地方就不动了
spice_work_flow criteria, s, flow_source(s), destination, d_row

是不是你的数据来源工作表需要“启用编辑”

microyip

http://club.excelhome.net/thread-1310803-1-1.html 多表多工作簿汇总，参考变通一下