VBV 多条件分类汇总，请大神帮忙~

ccrxao

亲爱的朋友您好！ 非常感谢您百忙中抽出宝贵的时间，查看我的求助帖子，非常希望得到您的帮助，谢谢！

附件中 A-I列为原始数据，怎么用VBA实现按条件分类汇总到 指定的单元格中；

请各位大神指点 ，非常感谢！

3190496160

Sub test()
Set d = CreateObject("scripting.dictionary")
rr = Array("101", "102", "531", "532")
With Sheet1
    .Range("k3:p5000") = Empty
    ar = .[a1].CurrentRegion
    For s = 0 To UBound(rr)
        k = 0: d.RemoveAll
        ReDim br(1 To UBound(ar), 1 To 6)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 2)) = Trim(rr(s)) Then
                t = d(Trim(ar(i, 5)))
                If t = "" Then
                    k = k + 1
                    d(Trim(ar(i, 5))) = k
                    t = k
                    br(k, 1) = Date
                    br(k, 2) = ar(i, 1)
                    br(k, 3) = ar(i, 4)
                    br(k, 4) = ar(i, 6)
                    br(k, 5) = ar(i, 5)
                End If
                br(t, 6) = br(t, 6) + (ar(i, 8) * 1000)
            End If
        Next i
        If s = 0 Then
            If k <> 0 Then
                .Cells(3, "k").Resize(k, UBound(br, 2)) = br
            End If
        ElseIf s > 0 Then
            If k <> "" Then
                ws = .Cells(Rows.Count, "k").End(xlUp).Row + 1
                .Range("k2:p2").Copy .Cells(ws, "k")
                .Cells(ws + 1, "k").Resize(k, UBound(br, 2)) = br
            End If
        End If
    Next s
End With
End Sub

3190496160

只写了第一个区域的代码，第二个区域自己依样画葫芦吧
VBA 分类汇总.rar (21.73 KB, 下载次数: 5)

2020-2-25 16:21 上传

点击文件名下载附件

ccrxao

3190496160 发表于 2020-2-25 16:20
Sub test()
Set d = CreateObject("scripting.dictionary")
rr = Array("101", "102", "531", "532")

非常感谢你的帮助，可否按图片的格式显示呢?

如果第二区的数据也是关联同一个订单下条件为：261,262吗？

另外：在单位换算的代码里 ， 是需要把TO(即吨的换算为千克)，我运行代码后显示的是 KG*1000

ccrxao

3190496160 发表于 2020-2-25 16:20
Sub test()
Set d = CreateObject("scripting.dictionary")
rr = Array("101", "102", "531", "532")

非常感谢您的帮助，我运行显示是每一行字段下面有一行数据：
字段
数据
字段
数据
.
.
.

可以实现如图片 K列到P列的 要格式吗？

另外：I列 单位是：TO的 需要转换为KG 并把H列对应的数量*1000

3190496160

不明白你在说什么，既然是批次取唯一值，那就必须同一个批次的数量相加呀，
比如：101，总共有四行数据，只有两个批次，0012033258和 0012493261
那最终结果，101肯定只有两行数据呀，哪来的很多行呢？

3190496160

至于 吨 的换算，戴增加一个判断即可
Sub test()
Set d = CreateObject("scripting.dictionary")
rr = Array("101", "102", "531", "532")
With Sheet1
    .Range("k3:p5000") = Empty
    ar = .[a1].CurrentRegion
    For s = 0 To UBound(rr)
        k = 0: d.RemoveAll
        ReDim br(1 To UBound(ar), 1 To 6)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 2)) = Trim(rr(s)) Then
                t = d(Trim(ar(i, 5)))
                If t = "" Then
                    k = k + 1
                    d(Trim(ar(i, 5))) = k
                    t = k
                    br(k, 1) = Date
                    br(k, 2) = ar(i, 1)
                    br(k, 3) = ar(i, 4)
                    br(k, 4) = ar(i, 6)
                    br(k, 5) = ar(i, 5)
                End If
                If Trim(ar(i, 9)) = "TO" Then
                    br(t, 6) = br(t, 6) + (ar(i, 8) * 1000)
                Else
                   br(t, 6) = br(t, 6) + ar(i, 8)
                End If
            End If
        Next i
        If s = 0 Then
            If k <> 0 Then
                .Cells(3, "k").Resize(k, UBound(br, 2)) = br
            End If
        ElseIf s > 0 Then
            If k <> "" Then
                ws = .Cells(Rows.Count, "k").End(xlUp).Row + 1
                .Range("k2:p2").Copy .Cells(ws, "k")
                .Cells(ws + 1, "k").Resize(k, UBound(br, 2)) = br
            End If
        End If
    Next s
End With
End Sub

ccrxao

3190496160 发表于 2020-2-25 17:05
不明白你在说什么，既然是批次取唯一值，那就必须同一个批次的数量相加呀，
比如：101，总共有四行数据， ...

对于我来说，大部分都已经成功了， 可能我不太了解VBA对中间的逻辑不是很清楚
我就想：对同一个订单下面的 移库类型为：101,102,531,532 以：订单号，物料号，批次取不重复值 汇总到K：P列，而表头的字段，如果订单号不同就加一个表头，如果相同的就不加！

3190496160

ccrxao 发表于 2020-2-25 17:47
对于我来说，大部分都已经成功了， 可能我不太了解VBA对中间的逻辑不是很清楚
我就想：对同一个订单下面 ...

呵呵，这样的话，代码就是另外一个思路的，呵呵

ccrxao

抽时间，请帮忙写一个好吗？