请老师帮忙写vba

eatnota

各位老师好




有个表是每天要筛选门店的库存状况给业务参考的资料
因为进销存的数据是每天累加的
每到月中和月底EXCEL会因为公式太多跑非常的慢
公式也没有可以简化的地方
如果改用vba要怎么改?
谢谢!

每天筛资料的方式:
货进太多：缺货FALSE→退货TRUE
要补货：缺货TRUE

cqlpjxx

你提供的数据有问题：根据 数据 表，是无法得出 销量 表的。

ykcbf1100

这个就是费时。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.4
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.         r = .Cells(Rows.Count, 7).End(3).Row
   
9.         zrr = .[g1].Resize(r, 3)
   
10.     End With
    
11.     For i = 2 To UBound(zrr)
    
12.         s = zrr(i, 1)
    
13.         d(s) = Val(zrr(i, 3))
    
14.     Next
    
15.     With Sheets("销量")
    
16.         tt = Val(.[m1].Value)
    
17.         rq = CDate(.[m2].Value)
    
18.         For i = 2 To UBound(arr)
    
19.             If CLng(arr(i, 1)) > CLng(rq) - tt And arr(i, 1) <= rq Then
    
20.                 s = arr(i, 2) & "|" & arr(i, 3)
    
21.                 d(s) = d(s) + arr(i, 4)
    
22.             End If
    
23.             If CDate(arr(i, 1)) = rq Then
    
24.                 s = arr(i, 2) & "|" & arr(i, 3)
    
25.                 d1(s) = d1(s) + arr(i, 5)
    
26.             End If
    
27.         Next
    
28.         r = .Cells(Rows.Count, 1).End(3).Row
    
29.         arr = .[a1].Resize(r, 12)
    
30.         For i = 4 To UBound(arr)
    
31.             For j = 3 To 7
    
32.                 s = arr(i, 1) & "|" & arr(3, j)
    
33.                 d(s) = arr(i, j)
    
34.             Next
    
35.         Next
    
36.         On Error Resume Next
    
37.         For i = 4 To UBound(arr)
    
38.             s = arr(i, 1) & "|" & arr(i, 2)
    
39.             .Cells(i, "i").Value = d(s)
    
40.             tmp = .Cells(i, "i").Value / tt
    
41.             t1 = d1(s) / tmp
    
42.             If Val(.Cells(i, "i").Value) > 0 Then
    
43.                 .Cells(i, "j").Value = Format(t1, "0") & "天"
    
44.             Else
    
45.                 .Cells(i, "j").Value = "没卖出"
    
46.             End If
    
47.             If Val(.Cells(i, "j").Value) >= d(arr(i, 2)) Then
    
48.                 .Cells(i, "k").Value = True
    
49.             Else
    
50.                 .Cells(i, "k").Value = False
    
51.             End If
    
52.             s = arr(i, 1) & "|" & rq
    
53.             ttt = d(s)
    
54.             If ttt < 3 Then
    
55.                 .Cells(i, "l").Value = True
    
56.             Else
    
57.                 .Cells(i, "l").Value = False
    
58.             End If
    
59.         Next
    
60.     End With
    
61.     Set d = Nothing
    
62.     Set d1 = Nothing
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "OK！"
    
65. End Sub
    
66. 
    

复制代码

壹万玖

是这个意思吧，拿走不谢！留了不少操作空间，你自己根据需求更改

壹万玖

1. Sub 库存统计()
   
2. '
   
3.     Application.ScreenUpdating = False
   
4.     Dim TiArr(), fArr(), xArr(), oArr(), mArr(), yArr()
   
5.     Dim fRDic, fCDic, xDic, fNa$, fDR&, mDR&, mDC%, TiC%, ii&, i%
   
6.    
   
7.     Set fRDic = CreateObject("Scripting.Dictionary")
   
8.     Set fCDic = CreateObject("Scripting.Dictionary")
   
9.     Set xDic = CreateObject("Scripting.Dictionary")
   
10.     TiArr = Array(" ", "每周的销量", "可卖幾天", "可能会退货", "可能会缺货")
    
11.    
    
12.     With ActiveWorkbook
    
13.         fArr = .Sheets("数据").UsedRange.Value
    
14.         xArr = .Sheets("过期").UsedRange.Value
    
15.         oArr = .Sheets("销量").Range("A1:A3").Value
    
16.     End With
    
17.     oArr(3, 1) = oArr(2, 1) - oArr(1, 1)
    
18.     For i = 1 To UBound(xArr, 1): xDic(xArr(i, 1)) = xArr(i, 3): Next
    
19.     fDR = UBound(fArr, 1): mDR = 1: mDC = 2
    
20.     ReDim mArr(1 To fDR, 1 To mDC), yArr(1 To fDR, 1 To mDC)
    
21.    
    
22.     For i = 1 To 2: mArr(mDR, i) = fArr(1, i + 1): yArr(mDR, i) = fArr(1, i + 1): Next
    
23.     For ii = 2 To fDR
    
24.         If fArr(ii, 1) > oArr(3, 1) And fArr(ii, 1) <= oArr(2, 1) Then
    
25.             If fCDic(fArr(ii, 1)) = "" Then
    
26.                 mDC = mDC + 1
    
27.                 ReDim Preserve mArr(1 To fDR, 1 To mDC), yArr(1 To fDR, 1 To mDC)
    
28.                 mArr(1, mDC) = fArr(ii, 1)
    
29.                 yArr(1, mDC) = fArr(ii, 1)
    
30.                 fCDic(fArr(ii, 1)) = mDC
    
31.             End If
    
32.             fNa = fArr(ii, 2) & fArr(ii, 3)
    
33.             If fRDic(fNa) = "" Then
    
34.                 mDR = mDR + 1
    
35.                 For i = 1 To 2
    
36.                     mArr(mDR, i) = fArr(ii, i + 1)
    
37.                     yArr(mDR, i) = fArr(ii, i + 1)
    
38.                 Next
    
39.                 fRDic(fNa) = mDR
    
40.             End If
    
41.             mArr(fRDic(fNa), fCDic(fArr(ii, 1))) = fArr(ii, 5)
    
42.             yArr(fRDic(fNa), fCDic(fArr(ii, 1))) = fArr(ii, 4)
    
43.         End If
    
44.     Next
    
45.    
    
46.     TiC = UBound(TiArr) + 1
    
47.     ReDim Preserve mArr(1 To fDR, 1 To mDC + TiC), yArr(1 To fDR, 1 To mDC + TiC)
    
48.     For i = 1 To TiC: mArr(1, mDC + i) = TiArr(i - 1): yArr(1, mDC + i) = TiArr(i - 1): Next
    
49.     For ii = 2 To mDR
    
50.         For i = 3 To mDC
    
51.             If yArr(1, i) > oArr(3, 1) And yArr(1, i) <= oArr(2, 1) Then
    
52.                 yArr(ii, mDC + 2) = yArr(ii, mDC + 2) + yArr(ii, i)
    
53.             End If
    
54.         Next
    
55.         mArr(ii, mDC + 2) = yArr(ii, mDC + 2)
    
56.         If mArr(ii, mDC + 2) <> 0 Then
    
57.             mArr(ii, mDC + 3) = mArr(ii, fCDic(oArr(2, 1))) / (mArr(ii, mDC + 2) / oArr(1, 1))
    
58.         Else
    
59.             mArr(ii, mDC + 3) = "没卖出"
    
60.         End If
    
61.         If mArr(ii, mDC + 3) >= xDic(mArr(ii, 2)) Then
    
62.             mArr(ii, mDC + 4) = "True"
    
63.         Else
    
64.             mArr(ii, mDC + 4) = "False"
    
65.         End If
    
66.         If mArr(ii, fCDic(oArr(2, 1))) < 3 Then
    
67.             mArr(ii, mDC + 5) = "True"
    
68.         Else
    
69.             mArr(ii, mDC + 5) = "False"
    
70.         End If
    
71.         For i = 3 To TiC: yArr(ii, mDC + i) = mArr(ii, mDC + i): Next
    
72.     Next
    
73.     mDC = mDC + TiC
    
74.    
    
75.     With ActiveWorkbook.Sheets("销量")
    
76.         .Cells.Clear
    
77.         .Range("A1:A2").Value = oArr
    
78.         .Range("A1").NumberFormatLocal = "0天"
    
79.         With .Range("A3").Resize(mDR, mDC)
    
80.             .Value = mArr
    
81.             .Columns(mDC - 2).NumberFormatLocal = "0天"
    
82.             .AutoFilter
    
83.         End With
    
84.         With .Columns(1).Resize(ColumnSize:=mDC)
    
85.             .HorizontalAlignment = xlCenter
    
86.             .VerticalAlignment = xlBottom
    
87.             .EntireColumn.AutoFit
    
88. End With
    
89.     End With
    
90.     Application.ScreenUpdating = True
    
91.     MsgBox "完成汇总 " & oArr(2, 1) & " 的数据！"
    
92. '
    
93. End Sub
    

复制代码

eatnota

太感谢老师了
我在好好研究

eatnota

各位老师
上次ykcbf1100老师帮忙写vba
我有更新excel
但不知道哪里改错了
跑出来的值怪怪的

有新增一个高水位的函数
但不知道怎么写vba

很需要老师们帮忙
谢谢!

翁知江安

Sub fenxi()
Dim i, j, k, m, n, irow, kk, p, s, t, x, y
Dim a
a = Timer
Dim ar, br, cr, dr
Dim d1, d2, d3, d4 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
irow = Sheets("数据").[a100000].End(xlUp).Row
ar = Sheets("数据").Range("a1:i" & irow)
For i = 2 To irow
  d1(ar(i, 2) & ar(i, 3) & ar(i, 1)) = d1(ar(i, 2) & ar(i, 3) & ar(i, 1)) + ar(i, 4)
  d3(ar(i, 2) & "," & ar(i, 3)) = ""
  If ar(i, 7) <> "" Then
  d4(ar(i, 7)) = ar(i, 9)
  End If
  If ar(i, 1) = Sheets("销量").[m2] Then
    If Not d2.exists(ar(i, 2) & ar(i, 3) & ar(i, 1)) Then
      d2(ar(i, 2) & ar(i, 3) & ar(i, 1)) = ar(i, 5)
       Else
         If ar(i, 5) < d2(ar(i, 2) & ar(i, 3) & ar(i, 1)) Then
          d2(ar(i, 2) & ar(i, 3) & ar(i, 1)) = ar(i, 5)
         End If
    End If
  End If
Next
ReDim br(1 To d3.Count, 1 To 2)
For Each kk In d3.keys
    m = m + 1
    For n = 1 To 2
    br(m, n) = Split(kk, ",")(n - 1)
    Next
Next
With Sheets("销量")
.[a4].Resize(m, 2) = br

ReDim cr(1 To d3.Count, 1 To 5)
For p = 3 To 7
   .Cells(3, p) = Format(.[m2] + p - 7, "yyyy/mm/dd")
   For s = 4 To d3.Count + 3
     cr(s - 3, p - 2) = d1(.Cells(s, 1).Value & .Cells(s, 2).Value & .Cells(3, p).Value)
   Next
Next
.Cells(4, 3).Resize(UBound(cr), 5) = cr
ReDim dr(1 To d3.Count, 1 To 4)
For s = 4 To d3.Count + 3
t = t + 1
dr(t, 1) = WorksheetFunction.Sum(.Cells(s, 3).Resize(1, 5))
x = d2(.Cells(s, 1).Value & "," & .Cells(s, 2).Value & "," & .[m2].Value)
If dr(t, 1) = 0 Then
   dr(t, 2) = "没卖出"
   Else
    dr(t, 2) = x / dr(t, 1)
End If
y = d4(.Cells(s, 2).Value)
If y <> "" And dr(t, 2) > y Then
     dr(t, 3) = "TRUE"
    Else
    dr(t, 3) = "FALSE"
End If
If dr(t, 2) < 3 Then
   dr(t, 4) = "TRUE"
Else
   dr(t, 4) = "FALSE"
End If
Next
.Cells(4, 9).Resize(UBound(dr), 4) = dr
End With
MsgBox Timer - a
MsgBox "ok"
End Sub

翁知江安

文件有点大，上传不了，抱歉。上述程序供参考。