简单进销存

kdsea

需要一个进销存数据统计，我做一份，老师看看代码是不是冗余而低效，请给出份代码，谢谢！

kdsea

Sub 库存()
    Range("A2:P10000").Clear
    arr = Sheets("5月底库").UsedRange
    brr = Sheets("入库").UsedRange
    crr = Sheets("出库").Range("A1").CurrentRegion
    Dim drr(1 To 1000, 1 To 5)
    '---------------------------------  期初
    Set d = CreateObject("scripting.dictionary")
    h = 1
    For i = 2 To UBound(arr)
        drr(h, 2) = arr(i, 1)
        drr(h, 3) = arr(i, 2)
        h = h + 1
    Next
    Range("A2").Resize(h - 2, 5) = drr
    Erase drr
    Set d = Nothing
    Set d = CreateObject("scripting.dictionary")
    LW = Cells(Rows.Count, "B").End(xlUp).Row + 1
    '---------------------------------  入库
    For i = 2 To UBound(brr)
        If d.Exists(brr(i, 4)) Then
            h = d(brr(i, 4))
            drr(h, 2) = brr(i, 4)
            drr(h, 4) = drr(h, 4) + brr(i, 7)
        Else
            k = k + 1
            d(brr(i, 4)) = k
            '        drr(k, 1) = brr(i, 1)
            drr(k, 2) = brr(i, 4)
            drr(k, 4) = brr(i, 7)
        End If
    Next
    Range("A" & LW).Resize(k, 5) = drr
    LW = Cells(Rows.Count, "B").End(xlUp).Row + 1
    Erase drr
    Set d = Nothing
    Set d = CreateObject("scripting.dictionary")
   
    k = 0: h = 0
    '---------------------------------  出库
    For i = 2 To UBound(crr)
        If d.Exists(crr(i, 2)) Then
            h = d(crr(i, 2))
            drr(h, 5) = drr(h, 5) + crr(i, 3)
        Else
            k = k + 1
            d(crr(i, 2)) = k
            '        drr(k, 1) = brr(i, 1)
            drr(k, 2) = crr(i, 2)
            drr(k, 5) = crr(i, 3)
        End If
    Next
    Range("A" & LW).Resize(k, 5) = drr
    Columns(1).Delete
   
    k = 0: h = 0
    Stop
    '===========================================合并
    Set d = Nothing
    Set d = CreateObject("scripting.dictionary")
    Dim Br(1 To 10000, 1 To 5)
    Ar = Range("A1").CurrentRegion
    On Error Resume Next
    For i = 1 To UBound(Ar)
    If d.Exists(Ar(i, 1)) Then
            h = d(Ar(i, 1))
            Br(h, 2) = Br(h, 2) + Ar(i, 2)
            Br(h, 3) = Br(h, 3) + Ar(i, 3)
            Br(h, 4) = Br(h, 4) + Ar(i, 4)
        Else
            k = k + 1
            d(Ar(i, 1)) = k
            '        drr(k, 1) = brr(i, 1)
            Br(k, 1) = Ar(i, 1)
            Br(k, 2) = Ar(i, 2)
            Br(k, 3) = Ar(i, 3)
            Br(k, 4) = Ar(i, 4)
        End If
    Next
    Range("A2:M10000").Clear
    Range("A1").Resize(k, 5) = Br
   [A1:E1] = Array("煤种", "期初库存", "入库", "出库", "结存")
End Sub

feilanga

先完成功能需求，无需考虑代码好坏。能实现需求的都是好代码。

kdsea

feilanga 发表于 2024-6-29 11:12
先完成功能需求，无需考虑代码好坏。能实现需求的都是好代码。

运行时间是要考虑的

longwin

供参考：

Sub test()
Range("A2:P10000").Clear
    arr = Sheets("5月底库").UsedRange
    brr = Sheets("入库").UsedRange
    crr = Sheets("出库").Range("A1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
    If arr(i, 1) <> "" Then
        If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
        d(arr(i, 1)) = Array(d(arr(i, 1))(0) + arr(i, 2), 0, 0)
    End If
    Next i
    For i = 2 To UBound(brr)
        If Not d.exists(brr(i, 4)) Then Set d(brr(i, 4)) = CreateObject("scripting.dictionary")
        d(brr(i, 4)) = Array(d(brr(i, 4))(0), d(brr(i, 4))(1) + brr(i, 7), 0)
    Next i
    For i = 2 To UBound(crr)
        If Not d.exists(crr(i, 2)) Then Set d(crr(i, 2)) = CreateObject("scripting.dictionary")
        d(crr(i, 2)) = Array(d(crr(i, 2))(0), d(crr(i, 2))(1), d(crr(i, 2))(2) + crr(i, 3))
    Next i
  Dim drr(1 To 1000, 1 To 5)
  For Each k1 In d.keys
        m = m + 1
        drr(m, 1) = k1
        drr(m, 2) = d(k1)(0)
        drr(m, 3) = d(k1)(1)
        drr(m, 4) = d(k1)(2)
        drr(m, 5) = drr(m, 2) + drr(m, 3) - drr(m, 4)
  Next
  [A2].Resize(m, 5) = drr
End Sub

kdsea

longwin 发表于 2024-6-30 11:13
供参考：

Sub test()

多谢  有些抽象，有时间了学习