日报汇总到月报中

babaymum

     各位老师，我想把每天进销的日报，用VBA自动填入到相应的月份表格中。
能不能帮忙实现一下，谢谢！

babaymum

各位大侠，这个真的有点难啊！！！有出手相助的吗

爱疯

Sub test()
    Dim A, d, i, j, k
    Set d = CreateObject("scripting.dictionary")

    '写字典
    A = Sheets(2).Range("a1").CurrentRegion
    For i = 2 To UBound(A)
        If A(i, 1) = "" Then A(i, 1) = A(i - 1, 1)
        d(A(i, 1) & A(i, 2)) = i                '行
    Next

    '查字典
    A = Sheets(1).Range("a1").CurrentRegion
    A(2, 3) = Replace(A(2, 3), "月", "") + 1    '表
    A(2, 4) = Replace(A(2, 4), "日", "") + 3    '列
    For i = 4 To UBound(A)
        For j = 3 To UBound(A, 2)
            k = A(i, 2) & A(3, j)    'd(k)查出行
            If d.exists(k) Then Sheets(A(2, 3)).Cells(d(k), A(2, 4)) = A(i, j)
        Next
    Next

End Sub


出入库日报填入2.rar (46.16 KB, 下载次数: 29)

2020-1-8 18:02 上传

点击文件名下载附件

babaymum

爱疯 发表于 2020-1-8 18:02
Sub test()
    Dim A, d, i, j, k
    Set d = CreateObject("scripting.dictionary")

谢谢大侠，完美解决了我的问题。
太谢谢了~~~~~

爱疯

AS 精华，不曾在每月里出现过，所以没处理。
是这样吗

babaymum

爱疯 发表于 2020-1-9 09:11
AS 精华，不曾在每月里出现过，所以没处理。
是这样吗

老师，是我漏写了，我追加进去也是可以导入到月明细记录表中的，谢谢。
这里是一部分的产品，我把剩余的都追加进去试试。
老师，太厉害了，代码简洁，功能强大。
我要把老师的代码看懂~~~~~

爱疯

出入库日报填入3.rar (47.64 KB, 下载次数: 9)

2020-1-9 09:46 上传

点击文件名下载附件




Sub test()
    Dim A, d, i, j, k


    '1）
    Set d = CreateObject("scripting.dictionary")
    A = Sheets(2).Range("a1").CurrentRegion
    For i = 2 To UBound(A)
        If A(i, 1) = "" Then A(i, 1) = A(i - 1, 1)
        d(A(i, 1) & A(i, 2)) = i                '行
    Next


    '2）
    Sheets(1).Select
    Range("a:a").Replace "~?", ""
    A = Range("a1").CurrentRegion
    A(2, 3) = Replace(A(2, 3), "月", "") + 1    '表
    A(2, 4) = Replace(A(2, 4), "日", "") + 3    '列


    '3）
    For i = 4 To UBound(A)
        For j = 3 To UBound(A, 2)
            k = A(i, 2) & A(3, j)
            If d.exists(k) Then
                Sheets(A(2, 3)).Cells(d(k), A(2, 4)) = A(i, j)
            Else
                A(i, 1) = A(i, 1) & "?": Exit For
            End If
        Next
    Next


    [a1].Resize(i - 1) = Application.Index(A, 0, 1)
End Sub




比3楼多个提醒：汇总表的项目不在每月中时，该项的序号后加了问号
因为不清楚需求，所以如上提醒。

babaymum

爱疯 发表于 2020-1-9 09:58
Sub test()
    Dim A, d, i, j, k

嗯，太谢谢了！

babaymum

爱疯 发表于 2020-1-8 18:02
Sub test()
    Dim A, d, i, j, k
    Set d = CreateObject("scripting.dictionary")

大侠：

     我还想增加一个功能，就是在《汇总》里把前日库存从相应的月份表里引用过来。

     我参考您之前写的代码，自己模仿写了一个，但是运行不了，我又找不出问题点了，

能帮我看一下吗？

爱疯

出入库日报填入5.rar (48.25 KB, 下载次数: 12)

2020-1-13 09:40 上传

点击文件名下载附件


Sub test()
    Dim A, d, i, j, k, y
    A = Sheets(2).Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(A)
        If A(i, 1) = "" Then A(i, 1) = A(i - 1, 1)
        d(A(i, 1) & A(i, 2)) = i 'key是品名和项目，item是行
    Next

    Sheets(1).Select
    Range("a:a").Replace "~?", ""
    A = Range("a1").CurrentRegion
    y = IIf(A(2, 5) = 1, DateSerial(Year(Date), A(2, 4), 0), A(2, 5) - 1)    '昨天
    For i = 4 To UBound(A)
        For j = 3 To UBound(A, 2) - 1
            k = A(i, 2) & A(3, j)
            If d.exists(k) Then
                '表名是月，行是item，列是某日
                Sheets(A(2, 4) & "月").Cells(d(k), IIf(j = 3, y, A(2, 5)) + 3) = A(i, j)
            Else
                A(i, 1) = A(i, 1) & "?": Exit For
            End If
        Next
    Next

    [a1].Resize(i - 1) = Application.Index(A, 0, 1)
End Sub



"汇总"工作表
1）D2和E2有自定义单元格格式，少两句代码，容易看些。
2）F列不用处理吧