动态匹配数据

yumz@123

大家好，要求说明：1，从测试数据复制数据“品名,料号,批次,数量”，F,H,J列对应的数据自动根据C列的料号匹配数据（从物料Sheet中），并G列等于E列*F列，如果C列删除，对应的后面也为空。谢谢大家！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("测试数据")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:d" & r)
   
9.     End With
   
10.     ReDim Preserve arr(1 To UBound(arr), 1 To UBound(arr, 2) + 5)
    
11.     For i = 1 To UBound(arr)
    
12.         d(CStr(arr(i, 2))) = i
    
13.     Next
    
14.     With Worksheets("物料")
    
15.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.         brr = .Range("a2:e" & r)
    
17.         For i = 1 To UBound(brr)
    
18.             If d.exists(CStr(brr(i, 2))) Then
    
19.                 m = d(CStr(brr(i, 2)))
    
20.                 arr(m, 5) = brr(i, 3)
    
21.                 arr(m, 7) = brr(i, 4)
    
22.                 arr(m, 9) = brr(i, 5)
    
23.             End If
    
24.         Next
    
25.     End With
    
26.     With Worksheets("做单")
    
27.         .UsedRange.Offset(1, 0).ClearContents
    
28.         .Range("b2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
29.     End With
    
30. End Sub
    

复制代码

chxw68

详见附件。

yumz@123

chxw68 发表于 2023-4-11 20:06
详见附件。

谢谢！我没有说清楚，我要做成单元格事件，能不能帮忙改下，非常感谢！

chxw68

yumz@123 发表于 2023-4-11 21:58
谢谢！我没有说清楚，我要做成单元格事件，能不能帮忙改下，非常感谢！

不清楚你的操作流程。是输入哪一列数据然后自动填写其他列的数据?

yumz@123

chxw68 发表于 2023-4-11 22:04
不清楚你的操作流程。是输入哪一列数据然后自动填写其他列的数据?

你好，是复制“测试数据”表的数据到“做单”表的B:E列，后触发事件，F,H,J列对应的数据自动匹配数据（从物料Sheet中），并G列等于E列*F列，如果清空后面则为空，谢谢！

ykcbf1100

yumz@123 发表于 2023-4-11 22:17
你好，是复制“测试数据”表的数据到“做单”表的B:E列，后触发事件，F,H,J列对应的数据自动匹配数据（从 ...

附件供参考。。。

chxw68

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("物料")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         brr = .Range("a2:e" & r)
   
9.         For i = 1 To UBound(brr)
   
10.             d(CStr(brr(i, 2))) = i
    
11.         Next
    
12.     End With
    
13.    
    
14.     With Worksheets("做单")
    
15.         r = .Columns("a:j").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
16.         arr = .Range("a2:j" & r)
    
17.         For i = 1 To UBound(arr)
    
18.             If Len(arr(i, 3)) = 0 Then
    
19.                 For j = 1 To UBound(arr, 2)
    
20.                     arr(i, j) = Empty
    
21.                 Next
    
22.             Else
    
23.                 If d.exists(CStr(arr(i, 3))) Then
    
24.                     m = d(CStr(arr(i, 3)))
    
25.                     arr(i, 6) = brr(m, 3)
    
26.                     arr(i, 8) = brr(m, 4)
    
27.                     arr(i, 10) = brr(m, 5)
    
28.                     arr(i, 7) = arr(i, 5) * arr(i, 6)
    
29.                 End If
    
30.             End If
    
31.         Next
    
32.         Application.EnableEvents = False
    
33.         .Range("a2:j" & r) = arr
    
34.         Application.EnableEvents = True
    
35.     End With
    
36. End Sub
    

复制代码

chxw68

详见附件。

yumz@123

ykcbf1100 发表于 2023-4-12 09:20
附件供参考。。。

感谢，要做成表格事件