计算物料周期

看飞鸟的金鱼

统计一下物料周期，跟踪物料消耗时间！

ykcbf1100

只提取了领料日期，其它计算没做

附件供参考。。。

ykcbf1100

1. Sub ykcbf()    '//2025.4.14
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("领料明细")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         Set Rng = .Range("a2:l" & r)
   
7.         Rng.Sort Rng.Columns(2), 1, Orientation:=1
   
8.         arr = Rng.Value
   
9.     End With
   
10.     For i = 1 To UBound(arr)
    
11.         If arr(i, 1) = Empty Then Exit For
    
12.         s = CStr(arr(i, 1))
    
13.         If InStr(d(s), arr(i, 2)) = 0 Then d(s) = d(s) & " " & arr(i, 2)
    
14.     Next
    
15.     On Error Resume Next
    
16.     With Sheets("所有商品")
    
17.         r = .Cells(Rows.Count, 1).End(3).Row
    
18.         c = .Cells(1, Columns.Count).End(1).Column
    
19.         For i = 2 To r
    
20.             s = CStr(arr(i, 1))
    
21.             col = 7
    
22.             If d.exists(s) Then
    
23.                 t = Split(Mid(d(s), 2))
    
24.                 For x = 0 To UBound(t)
    
25.                     .Cells(i, col) = CDate(t(x))
    
26.                     col = col + 3
    
27.                 Next
    
28.             End If
    
29.         Next
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = False
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

taller

1. 
   
2. Sub Demo()
   
3.     With Sheets("领料明细").Range("A1").CurrentRegion
   
4.         .Sort Key1:=.Columns(2), Order1:=xlDescending, Header:=xlYes
   
5.         Dim arr: arr = .Value
   
6.     End With
   
7.     Dim dict: Set dict = CreateObject("Scripting.Dictionary")
   
8.     Dim i, j, k, crr
   
9.     For i = 2 To UBound(arr, 1)
   
10.         If Not dict.Exists(arr(i, 1)) Then
    
11.             dict.Add arr(i, 1), arr(i, 2)
    
12.         Else
    
13.             ' 同一天多次领料只记录一次
    
14.             If InStr(1, dict(arr(i, 1)), arr(i, 2)) = 0 Then _
    
15.             dict(arr(i, 1)) = dict(arr(i, 1)) & " " & arr(i, 2)
    
16.         End If
    
17.     Next
    
18.     Const SCOL = 7 ' 最近第1次领料日期 所在列
    
19.     Dim iCol As Long
    
20.     With Sheets("所有商品").Range("A1").CurrentRegion
    
21.         .Resize(.Rows.Count - 1, .Columns.Count - 4).Offset(1, 4).ClearContents
    
22.         Dim brr: brr = .Value
    
23.         For i = 2 To UBound(brr, 1)
    
24.             If dict.Exists(brr(i, 1)) Then
    
25.                 crr = Split(dict(brr(i, 1)), " ")
    
26.                 For j = 0 To UBound(crr)
    
27.                     iCol = SCOL + j * 3
    
28.                     If iCol > UBound(brr, 2) Then
    
29.                         MsgBox "请扩充标题行包含足够多的列数用于保存结果数据"
    
30.                         Exit Sub
    
31.                     End If
    
32.                     brr(i, iCol) = crr(j)
    
33.                     If j > 0 Then _
    
34.                         brr(i, iCol - 4) = CDate(brr(i, iCol - 3)) - CDate(brr(i, iCol))
    
35.                     If j > 1 Then _
    
36.                         brr(i, iCol - 8) = brr(i, iCol - 7) - brr(i, iCol - 4)
    
37.                 Next
    
38.             End If
    
39.         Next
    
40.         .Value = brr
    
41.     End With
    
42. End Sub

复制代码

翁知江安

Sub test250415()
Dim i, j, k, m, n, p As Integer, d1, d2 As Object, ar, br, cr As Variant
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Sheets("领料明细").[a1].CurrentRegion
For i = UBound(ar) To 2 Step -1
   If ar(i, 1) <> "" Then
       d1(ar(i, 1)) = 1 + d1(ar(i, 1)): d2(ar(i, 1) & d1(ar(i, 1))) = ar(i, 2)
    End If
Next
br = Sheets("所有商品").UsedRange
For j = 7 To UBound(br, 2)
  If InStr(br(1, j), "最近") > 0 Then
    m = WorksheetFunction.Find("第", br(1, j)): n = WorksheetFunction.Find("次", br(1, j))
    p = Val(Mid(br(1, j), m + 1, n - m - 1))
    For i = 2 To UBound(br)
    br(i, j) = d2(br(i, 1) & p)
    Next
   End If
Next
For i = 2 To UBound(br)
    br(i, 5) = WorksheetFunction.Max(DateDiff("d", br(i, 7), br(i, 10)), 0): br(i, 6) = WorksheetFunction.Max(br(i, 5) - 1, 0)
    br(i, 8) = WorksheetFunction.Max(DateDiff("d", br(i, 10), br(i, 13)), 0): br(i, 9) = WorksheetFunction.Max(br(i, 8) - 1, 0)
    br(i, 11) = WorksheetFunction.Max(DateDiff("d", br(i, 13), br(i, 15)), 0): br(i, 12) = WorksheetFunction.Max(br(i, 11) - 1, 0)
    For j = 14 To 24 Step 2
    br(i, j) = WorksheetFunction.Max(DateDiff("d", br(i, j + 1), br(i, j + 3)) - 1, 0)
    Next
Next
Sheets("所有商品").[a1].Resize(UBound(br), UBound(br, 2)) = br
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

看飞鸟的金鱼

ykcbf1100 发表于 2025-4-14 18:03

感谢老师的回复！这个每一个物料都有领料日期，不是这样呀！

看飞鸟的金鱼

taller 发表于 2025-4-15 01:31

感谢老师的回复！

看飞鸟的金鱼

翁知江安 发表于 2025-4-15 09:34
供参考，欢迎批评指正

感谢老师的回复！回去看看代码！这个新增领料明细后重新运行它好像不会把新增日期填上去？有没有办法让最近日期排在前面，比如3月31日排在3月15日前面，有新增领料时日期往后顺延排序（类似于降序排序）