关于数据转换取值

吴中泉

请测试这个最新的
字典分解总表到多个分表.rar (59.06 KB, 下载次数: 12)

2023-5-17 18:58 上传

点击文件名下载附件

slonby

吴中泉 发表于 2023-5-17 15:24
经过一段时间编辑和测试，自认为符合你的要求，请你再测试一下。若可行，动动你发财的大手

附件呢？

吴中泉

slonby 发表于 2023-5-17 15:31
附件呢？

在11楼，可能刚才审核还没通过

吴中泉

Sub ssjss()    '//2023.5.17
    Dim arr, brr, d, T
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Dim tm: tm = Timer
    brr = [{"入库表","出库表"}]
    For x = 1 To 2
        arr = Sheets(brr(x)).UsedRange.Value
        For i = 2 To UBound(arr)
            yf = Month(arr(i, 3)) 'yf月份
            rq = Day(arr(i, 3)) 'rq日期
            T = arr(i, 9) & "|" & arr(i, 2) & "|" & yf & "|" & rq
            d(T) = d(T) + arr(i, 13) 'T不同的字典键值
            d2(arr(i, 9) & "-" & yf) = yf
        Next
    Next
    For Each sht In Sheets '遍历12个月
        If Val(sht.Name) Then
            With sht
                yf = Val(.Name)
                .UsedRange.Offset(1).Clear
                i = 2
                For Each bh In d2.keys 'bh商品编号+月份
                    If yf = d2(bh) Then
                        i = i + 1
                        .Cells(i, 1) = Split(bh, "-")(0) '生成当月的不重复商品编号
                    End If
                Next
                arr = .UsedRange.Value
                For i = 2 To UBound(arr)
                    T = arr(i, 1)
                    If T <> Empty Then
                        For j = 6 To UBound(arr, 2)
                            If arr(1, j) = Empty Then Exit For
                            kb = Right(Trim(arr(1, j)), 2) 'kb库别
                            rq = Val(arr(1, j)) 'rq日期
                            T = arr(i, 1) & "|" & kb & "|" & yf & "|" & rq
                            If d.exists(T) Then
                                arr(i, j) = d(T)
                                If kb = "入库" Then
                                    arr(i, 3) = arr(i, 3) + arr(i, j) '入库数量
                                Else
                                    arr(i, 4) = arr(i, 4) + arr(i, j) '出库数量
                                End If
                            End If
                        Next
                            arr(i, 2) = d2(arr(i, 1)) '上、上月库存
                            arr(i, 5) = arr(i, 2) + arr(i, 3) - arr(i, 4) '本月库存
                            d2(arr(i, 1)) = arr(i, 5) '库存结转
                    End If
                Next
                .UsedRange.Value = arr
            End With
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "共用时：" & Format(Timer - tm, "0.0秒")
End Sub

吴中泉

ykcbf1100 发表于 2023-5-17 11:54
用字典写的，但感觉速度有点慢啊，我的电脑上要好几分钟。

仅供参考。。。

陈老师，你的电脑有那么老么？我运行只要0.1秒

ykcbf1100

吴中泉 发表于 2023-5-17 16:08
陈老师，你的电脑有那么老么？我运行只要0.1秒

真的？我这个本本16G内存呢

zxsea_7426

ykcbf1100 发表于 2023-5-17 16:10
真的？我这个本本16G内存呢

我发现你的代码为什么这么慢了，我运行你的代码还内存溢出报错了。


像我这样小内存的机器就报内存溢出了。

ykcbf1100

zxsea_7426 发表于 2023-5-17 18:40
我发现你的代码为什么这么慢了，我运行你的代码还内存溢出报错了。

原来如此。谢谢。
我有时间再查一下。

aifeiqi

吴中泉 发表于 2023-5-17 15:29
请测试这个最新的

1、老师，测试过了完全达到要求，谢谢；
2、还要再麻烦一下，请帮忙看附件里模块1年度汇总表代码，之前是好用的，加了入库表，和出库表这两个工作表，现执行不了
3、入库表和出库表不参与年度汇总，参与年度汇总的只是1-12个月的分表

吴中泉

aifeiqi 发表于 2023-5-18 08:44
1、老师，测试过了完全达到要求，谢谢；
2、还要再麻烦一下，请帮忙看附件里模块1年度汇总表代码，之前 ...

你这个代码我没有修改过?我来帮你看看