根据数据表信息，提取需要的信息，请各位老师进来看看下咯！小弟在线等哈！

hmc530

如截图说明，具体的请各位老师下载附件帮忙看下咯！！谢谢了！


例子1.zip (1014.89 KB, 下载次数: 15)

2024-11-27 13:35 上传

点击文件名下载附件

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a2").CurrentRegion.Value
   
5. For i = 2 To UBound(arr)
   
6.     If Not dic.exists(arr(i, 2)) Then Set dic(arr(i, 2)) = CreateObject("scripting.dictionary")
   
7.     If Not dic(arr(i, 2)).exists(arr(i, 4)) Then
   
8.         dic(arr(i, 2))(arr(i, 4)) = Array(arr(i, 7), arr(i, 11), arr(i, 15))
   
9.     End If
   
10. Next
    
11. brr = Sheet6.[a2].CurrentRegion.Value
    
12. For j = 6 To 27 Step 3
    
13.     For i = 3 To UBound(brr)
    
14.         s = brr(1, j): s2 = brr(i, 4)
    
15.         If dic(s).exists(s2) Then
    
16.             a = dic(s)(s2)
    
17.             For c = 0 To 2
    
18.                 brr(i, j + c) = a(c)
    
19.             Next c
    
20.         Else
    
21.             brr(i, j) = "已满箱"
    
22.         End If
    
23.     Next i
    
24. Next j
    
25. Sheet6.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
26. Set dic = Nothing
    
27. End Sub

复制代码

Qs18

试试.........

Qs18

试试.........

蓝桥玄霜

例子的例子：

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.27
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("未到货台账")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 15)
   
7.     End With
   
8.     For i = 3 To UBound(arr)
   
9.         s = arr(i, 2) & "|" & arr(i, 4)
   
10.         If Val(arr(i, 1)) Then
    
11.             If Not d.exists(s) Then
    
12.                 d(s) = Array(arr(i, 7), arr(i, 11), arr(i, 15))
    
13.             Else
    
14.                 t = d(s)
    
15.                 t(0) = IIf(InStr(t(0), arr(i, 7)), t(0), t(0) & "/" & arr(i, 7))
    
16.                 t(1) = IIf(InStr(t(1), arr(i, 11)), t(1), t(1) & "/" & arr(i, 11))
    
17.                 t(2) = IIf(InStr(t(2), arr(i, 15)), t(2), t(2) & "/" & arr(i, 15))
    
18.                 d(s) = t
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     With Sheets("明细数据汇总")
    
23.         r = .Cells(Rows.Count, 1).End(3).Row
    
24.         c = .Cells(3, Columns.Count).End(1).Column
    
25.         arr = .[a1].Resize(r, c)
    
26.         For j = 6 To UBound(arr, 2) Step 3
    
27.             For i = 4 To UBound(arr)
    
28.                 s = arr(2, j) & "|" & arr(i, 4)
    
29.                 If d.exists(s) Then
    
30.                     arr(i, j) = d(s)(0)
    
31.                     arr(i, j + 1) = d(s)(1)
    
32.                     arr(i, j + 2) = d(s)(2)
    
33.                 Else
    
34.                     arr(i, j) = "已满箱"
    
35.                     arr(i, j + 1) = ""
    
36.                     arr(i, j + 2) = ""
    
37.                 End If
    
38.             Next
    
39.         Next
    
40.         .[a1].Resize(r, c) = arr
    
41.     End With
    
42.     Set d = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    
46. 
    

复制代码

deadzlq

PQ参考解法

yynrzwh

yanglinzi