采购单，没有编码

sz216

如图，两个文件表的主要区别，1,客户的采购单，没有编码，2,商品名称跟供货商对不上。
供货商在入录时候，商品名称不一样的，用备注代替。客户采购单里面的的商品名称已经在供货商的备注和商品名称里面。
需要解决问题：用VBA,把客户采购单商品名称换成供货商的采购表相同加入商品编号，不相同的加到备注。其他的客户名称，下单数量不变。（如图：效果）

ykcbf1100

编码不全啊

附件供参考。。。

ykcbf1100

1. Sub ykcbf()   '//2025.3.22
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("效果")
   
6.     arr = sh.[a1].CurrentRegion
   
7.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
8.     For j = 1 To UBound(arr, 2)
   
9.         d(arr(1, j)) = j
   
10.     Next
    
11.     arr = Sheets("客户采购单").UsedRange
    
12.     For i = 2 To UBound(arr)
    
13.         If Len(arr(i, 1)) Then
    
14.             m = m + 1
    
15.             For j = 1 To UBound(arr, 2)
    
16.                 s = arr(1, j)
    
17.                 If d.exists(s) Then
    
18.                     brr(m, d(s)) = arr(i, j)
    
19.                 End If
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     arr = Sheets("供货商").UsedRange
    
24.     For j = 2 To UBound(arr, 2)
    
25.         For i = 2 To UBound(arr)
    
26.             d1(arr(i, j)) = i
    
27.         Next
    
28.     Next
    
29.     For i = 1 To m
    
30.         s1 = brr(i, 2)
    
31.         If d1.exists(s1) Then
    
32.             r = d1(s1)
    
33.             For j = 1 To UBound(arr, 2)
    
34.                 s = arr(1, j)
    
35.                 If d.exists(s) Then
    
36.                     brr(i, d(s)) = arr(r, j)
    
37.                 End If
    
38.             Next
    
39.         End If
    
40.     Next
    
41.     sh.[h2].Resize(m, 5) = brr
    
42.     sh.[h2].Resize(m, 5).Borders.LineStyle = 1
    
43.     Set d = Nothing
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    

复制代码

sz216

ykcbf1100 发表于 2025-3-22 07:48

类型不匹配

ykcbf1100

sz216 发表于 2025-3-23 18:34
类型不匹配

你看看我上传的附件，都已经出结果了，你还类型不匹配。

戎马书生222

我写了下程序，好像编码不全。

1. Sub abey()
   
2. Dim arr, brr, crr, i&, j&, r&
   
3. Set d1 = VBA.CreateObject("scripting.dictionary")
   
4. Set d2 = VBA.CreateObject("scripting.dictionary")
   
5. arr = Sheets("客户采购单").Range("a1").CurrentRegion
   
6. brr = Sheets("供货商").Range("a1").CurrentRegion
   
7. ReDim crr(1 To UBound(arr), 1 To 5)
   
8. For j = 2 To 3
   
9.     For i = 2 To UBound(brr)
   
10.         s = brr(i, j)
    
11.         If s <> "" Then
    
12.             If j = 2 Then
    
13.                 If Not d1.exists(s) Then d1(s) = brr(i, 1)
    
14.             Else
    
15.                 If Not d2.exists(s) Then d2(s) = brr(i, 1) & "," & brr(i, 2)
    
16.             End If
    
17.         End If
    
18.     Next
    
19. Next
    
20. 
    
21. For i = 2 To UBound(arr)
    
22.     s = arr(i, 1)
    
23.     If s <> "" Then
    
24.         If d1.exists(s) Then
    
25.             crr(i, 1) = d1(s)
    
26.             crr(i, 2) = arr(i, 1)
    
27.             
    
28.             crr(i, 4) = arr(i, 2)
    
29.             crr(i, 5) = arr(i, 3)
    
30.         Else
    
31.             If d2.exists(s) Then
    
32.                 ss = Split(d2(s), ",")
    
33.                 crr(i, 1) = ss(0)
    
34.                 crr(i, 2) = arr(i, 1)
    
35.                 crr(i, 3) = ss(1)
    
36.                 crr(i, 4) = arr(i, 2)
    
37.                 crr(i, 5) = arr(i, 3)
    
38.             Else
    
39.                 crr(i, 2) = arr(i, 1)
    
40.                 crr(i, 4) = arr(i, 2)
    
41.                 crr(i, 5) = arr(i, 3)
    
42.             End If
    
43.         End If
    
44.     End If
    
45.    
    
46. Next i
    
47. crr(1, 1) = "商品编号": crr(1, 2) = "商品名称": crr(1, 3) = "备注": crr(1, 4) = "客户名称": crr(1, 5) = "下单数量"
    
48. Sheets("效果").Range("a1").Resize(UBound(arr), 5) = crr
    
49. 
    
50. End Sub
    

复制代码

翁知江安

Sub test()
Dim i, j, k As Integer
Dim ar, br, cr As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ar = Sheets("供货商").UsedRange
For i = 2 To UBound(ar)
   d(ar(i, 2)) = i
   If ar(i, 3) <> "" Then
    d(ar(i, 3)) = i
    End If
Next
br = Sheets("客户采购单").UsedRange
ReDim cr(1 To UBound(br) - 1, 1 To 5)
For k = 2 To UBound(br)
    For j = 1 To 3
    cr(k - 1, j) = ar(d(br(k, 1)), j)
    Next
    For j = 4 To 5
    cr(k - 1, j) = br(k, j - 2)
    Next
Next
Sheets("效果").[a2].Resize(1000, 5).ClearContents
Sheets("效果").[a2].Resize(UBound(cr), 5) = cr
MsgBox "ok"
End Sub

翁知江安

个别地方的名称不一致，已作了修改。供参考，欢迎批评指正

sz216

戎马书生222 发表于 2025-3-23 21:39
我写了下程序，好像编码不全。

商品编号少了一个0.