请问各位大佬，如何把原始表中的数据按模板进行提取汇总？十分感谢

tree945

请问各位大佬，如何把原始表中的数据按模板进行提取汇总？十分感谢！

前两个SHEET一样，一个单位分一个SHEET，数据都来自原始数据，
相同名称、规格型号、批号的产品，数量与金额求和汇总，其它项直接取值


实在抱歉，刚才附件上传有误，已更新

limonet

看不懂啊，你模拟的都不对。不是误导，就是增加难度，你都不认真，谁认真。

产品名称 as 名称,规格型号 as 规格,单位,批号 as 序列号,数量,生产日期,有效期至 as 效期,销售单价 as 单价,销售金额 as 金额,证号 as 注册证号,生产企业许可证号 as 生产许可证号,储运条件,生产企业

tree945

limonet 发表于 2023-3-9 22:49
看不懂啊，你模拟的都不对。不是误导，就是增加难度，你都不认真，谁认真。

产品名称 as 名称,规格型号  ...

实在抱歉，刚才附件上传有误，已更新，谢谢您的指正

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 2 Then sh.Delete
Next sh
Application.DisplayAlerts = True
With Sheets("原始数据")
    r = .Cells(Rows.Count, 12).End(xlUp).Row
    ar = .Range("a1:ad" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 12)) <> "" Then
        d(Trim(ar(i, 12))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 13)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 12)) = k Then
            zd = Trim(ar(i, 14)) & "|" & Trim(ar(i, 15)) & "|" & Trim(ar(i, 17))
            t = d(zd)
            If t = "" Then
                n = n + 1
                d(zd) = n
                t = n
                For j = 14 To 16
                    br(n, j - 13) = ar(i, j)
                Next j
                br(n, 5) = ar(i, 30)
                br(n, 6) = ar(i, 17)
                br(n, 7) = ar(i, 19)
                br(n, 8) = ar(i, 20)
                br(n, 9) = ar(i, 23)
                br(n, 11) = ar(i, 29)
                br(n, 12) = ar(i, 28)
                br(n, 13) = ar(i, 26)
            End If
            br(t, 4) = br(t, 4) + ar(i, 18)
            br(t, 10) = br(t, 10) + ar(i, 23)
        End If
    Next i
    Sheets("模板").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = k
        .[A1] = k
        .[a4].Resize(n, UBound(br, 2)) = br
        .Rows(n + 4 & ":35").Delete
    End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

模板.rar (29.49 KB, 下载次数: 12)

2023-3-10 08:43 上传

点击文件名下载附件

limonet

tree945 发表于 2023-3-9 23:01
实在抱歉，刚才附件上传有误，已更新，谢谢您的指正

有多少个单位就新建多少个sheet？

limonet

如果要新建sheet,代码要多加。

tree945

limonet 发表于 2023-3-10 09:02
有多少个单位就新建多少个sheet？

三个就足够了，谢谢

limonet

代码在审核。

limonet

Sub limonet()
    Dim ADO As Object, StrSQL$, Sht As Worksheet
    Set ADO = CreateObject("adodb.connection")
    ADO.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "原始数据" Then
            StrSQL = "first(产品名称) as 名称,first(规格型号) as 规格,first(单位) as 单位,sum(数量) as 数量,first(生产企业) as 生产企业,first(批号) as 序列号,first(生产日期) as 生产日期,first(有效期至) as 效期,first(销售单价) as 单价,sum(销售金额) as 金额,first(储运条件) as 储运条件,first(生产企业许可证号) as 生产许可证号,first(证号) as 注册证号"
            StrSQL = "SELECT " & StrSQL & " FROM [excel 12.0;database=" & ThisWorkbook.FullName & "].[原始数据$] where 供货单位='" & Mid(Sht.Name, 4, 99) & "' group by 产品名称,规格型号,批号"
            Sht.Range("A4").CopyFromRecordset ADO.Execute(StrSQL)
        End If
    Next Sht
    Set ADO = Nothing
End Sub