公式转换成VBA中的代码

ykcbf1100

1. Sub ykcbf()   '//2025.3.22
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Sheets("粘贴区").UsedRange
   
4.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
5.     With Sheets("复制区")
   
6.         rq = CDate(.[f1])
   
7.         For i = 3 To UBound(arr)
   
8.             If CDate(arr(i, 4)) = rq Then
   
9.                 s = arr(i, 1)
   
10.                 If Not d.exists(s) Then
    
11.                     m = m + 1
    
12.                     d(s) = m
    
13.                     brr(m, 1) = m
    
14.                     brr(m, 2) = arr(i, 3)
    
15.                     brr(m, 3) = arr(i, 2)
    
16.                     brr(m, 4) = arr(i, 4)
    
17.                     brr(m, 5) = arr(i, 1)
    
18.                 Else
    
19.                     r = d(s)
    
20.                     brr(r, 3) = brr(r, 3) + arr(i, 2)
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         .[a3].Resize(1000, 5) = Empty
    
25.         .[a3].Resize(m, 5) = brr
    
26.     End With
    
27. End Sub
    

复制代码

张韶均

ykcbf1100 发表于 2025-3-22 20:16
参与一下。。。

感恩你 现在工作时间有要缩短

张韶均

3190496160 发表于 2025-3-22 19:44

谢谢你 现在工作时间有要缩短

张韶均

凌空一羽 发表于 2025-3-22 19:08

你这方法不错，辛苦了

张韶均

帮忙转VBA

ykcbf1100

张韶均 发表于 2025-4-3 10:51
帮忙转VBA

公式我看不太懂啊。
样品发明细表是根据表头的客户和日期提取Sheet1表中的数据吗？

张韶均

ykcbf1100 发表于 2025-4-3 11:01
公式我看不太懂啊。
样品发明细表是根据表头的客户和日期提取Sheet1表中的数据吗？

发货明细表输入日期，客户和明细全部显示

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()   '//2025.4.3
   
2.     Application.ScreenUpdating = False
   
3.     With Sheet1
   
4.         r = .Cells(Rows.Count, 2).End(3).Row
   
5.         arr = .Range("a1", .Cells(r, 15))
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr), 1 To 14)
   
8.     With Sheets("样品发明细")
   
9.         rq = CDate(.[f1].Value)
   
10.         .UsedRange.Offset(2) = Empty
    
11.         For i = 3 To UBound(arr)
    
12.             If arr(i, 15) = rq Then
    
13.                 m = m + 1
    
14.                 For j = 2 To UBound(arr, 2)
    
15.                     brr(m, j - 1) = arr(i, j)
    
16.                 Next
    
17.             End If
    
18.         Next
    
19.         .[a3].Resize(m, 14) = brr
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "OK！"
    
23. End Sub
    
24. 
    

复制代码

张韶均

B格能显示序号吗？