库存剩余产品序列号问题

转身是天涯

计算库存中相同产品相同批号的剩余序列号

mmx1122

明细表也是这种格式吗

一把小刀闯天下

'输出格式修改了一下。另你只有修改三处注释处就可以了，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, m, n, t, dic(1), flag, key, p
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  ReDim arr(1)
  arr(0) = Range("a3:e" & Cells(Rows.Count, "b").End(xlUp).Row) '入库位置
  arr(1) = Range("g3:k" & Cells(Rows.Count, "h").End(xlUp).Row) '出库位置
  ReDim brr(1 To UBound(arr(0), 1) + UBound(arr(1), 1), 6)
  For i = 0 To 1
    For j = 1 To UBound(arr(i), 1)
      m = m + 1
      For k = 1 To UBound(arr(i), 2)
        brr(m, k) = arr(i)(j, k)
      Next
      brr(m, k) = i
    Next
  Next
  For i = 1 To UBound(brr, 1)
    t = brr(i, 1) & "," & brr(i, 2)
    If brr(i, 6) = 0 Then
      If Len(brr(i, 5)) Then
        For j = Val(brr(i, 3)) To Val(brr(i, 5))
          dic(0)(t) = dic(0)(t) & "," & j
        Next
      Else
        dic(0)(t) = dic(0)(t) & "," & Val(brr(i, 3))
      End If
    Else
      If flag = 1 Then
        If Len(brr(i, 5)) Then
          For j = Val(brr(i, 3)) To Val(brr(i, 5))
            dic(0)(t) = Replace(dic(0)(t), "," & j & ",", ",")
          Next
        Else
          dic(0)(t) = Replace(dic(0)(t), "," & Val(brr(i, 3)) & ",", ",")
        End If
      Else
        For Each key In dic(0).keys
          dic(0)(key) = dic(0)(key) & ","
        Next
        flag = 1: i = i - 1
      End If
    End If
  Next
  ReDim arr(1 To dic(0).Count * 100, 1 To 5)
  m = 0
  For Each key In dic(0).keys
    If Len(dic(0)(key)) > 1 Then
      n = 0: dic(1).RemoveAll
      t = Split(dic(0)(key), ",")
      For i = 0 To UBound(t)
        dic(1)(t(i)) = 1
      Next
      t = dic(1).keys
      ReDim temp(1 To UBound(t) + 1)
      For i = 1 To UBound(t)
        temp(i) = Val(t(i))
      Next
      For i = 1 To UBound(temp) - 2
        For j = i + 1 To UBound(temp) - 1
          If temp(i) > temp(j) Then
            t = temp(i): temp(i) = temp(j): temp(j) = t
          End If
        Next
      Next
      t = Split(key, ","): p = 1
      For i = 2 To UBound(temp)
        If temp(i) - temp(i - 1) <> 1 Then
          m = m + 1
          arr(m, 1) = t(0): arr(m, 2) = t(1)
          If i - p > 1 Then
            arr(m, 3) = temp(p)
            arr(m, 4) = "-"
            arr(m, 5) = temp(i - 1)
          Else
            arr(m, 3) = temp(p)
          End If
          p = i
        End If
      Next
    End If
  Next
  With [m3] '输出位置
    .Resize(Rows.Count - 2, 5).Clear
    If m > 0 Then
      With .Resize(m, 5)
        .NumberFormatLocal = "0000"
        .Borders.LineStyle = xlContinuous
        .Value = arr
      End With
    End If
  End With
End Sub

转身是天涯

一把小刀闯天下 发表于 2019-12-17 14:24
Option Explicit

Sub test()

我的企鹅：1257244864
方便的话加我一下，还请多指教

转身是天涯

mmx1122 发表于 2019-12-17 12:25
明细表也是这种格式吗

就按我图上格式就可以，完了我再结合实际工作需要再改改

一把小刀闯天下

转身是天涯 发表于 2019-12-17 15:27
就按我图上格式就可以，完了我再结合实际工作需要再改改

3楼代码修改了一下，看一下第一行注释，，，

转身是天涯

一把小刀闯天下 发表于 2019-12-17 17:16
3楼代码修改了一下，看一下第一行注释，，，

嗯嗯，好的，谢谢老师
Sub Auto_Close()
ActiveWindow.CloseActiveWorkbook.SaveCopyAs "E:\库存\库存共享\" & ThisWorkbook.Name & Format(Now, "yyyymmdd")
end sub
我想关闭时自动保存文件，重命名文件名+此时时间，这样写不可以么？还是我哪里错了？

一把小刀闯天下

放在ThisWorkbook中的Workbook事件里，自己查一下怎么用就可以了，，，

转身是天涯

一把小刀闯天下 发表于 2019-12-17 14:24
'输出格式修改了一下。另你只有修改三处注释处就可以了，，，

Option Explicit

您看看这个，问题在里边

一把小刀闯天下

看了一下工作表变掉了，序列号格式也变掉了。给个思路代码就不敲了：

1、在 If flag = 1 Then 中，replace前用instr判断一下字典中是否存在这个序号，如果没有弹出提示框提示那个型号及序号，直接exit sub

2、原来就有这个功能。当入库中的某个型号完全出库后这个型号将不会输出的（If Len(dic(0)(key)) > 1 Then，为1时仅为一个逗号，也就是数据已为空，此时将跳过这个型号）