订单匹配问题

zjhclub

订单匹配问题，有三个工作表，根据采购订单信息，匹配相关出入库信息，求老师帮忙，谢谢！

lsc900707

可以用字典去匹配。

zjhclub

lsc900707 发表于 2018-10-11 21:59
可以用字典去匹配。

自己编了个程序，效果不好，有点问题，老师看看能帮我修改一下吗

zjhclub

lsc900707 发表于 2018-10-11 21:59
可以用字典去匹配。

1. Sub 汇总()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. Dim str As String
   
6. Dim temp As String
   
7. arr = Sheets("采购订单").[a1].CurrentRegion.Offset(1)
   
8. brr = Sheets("采购入库").[a1].CurrentRegion.Offset(1)
   
9. crr = Sheets("销售出库").[a1].CurrentRegion.Offset(1)
   
10. For i = 1 To UBound(arr)
    
11.     If arr(i, 4) <> "" Then
    
12.         If arr(i, 5) <> "" Then
    
13.             str = arr(i, 5) & "@" & arr(i, 6)
    
14.             If Not d.exists(arr(i, 4)) Then
    
15.                 Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
    
16.             End If
    
17.             d(arr(i, 4))(str) = ""
    
18.         End If
    
19.     End If
    
20. Next
    
21. For j = 1 To UBound(brr)
    
22.    If brr(j, 12) <> "" Then
    
23.         If Not d1.exists(brr(j, 12)) Then
    
24.             If brr(j, 5) <> "" Then
    
25.                 'd1(brr(j, 7)) = d1(brr(j, 7)) + brr(j, 5)
    
26.                 temp = brr(j, 5)
    
27.             Else
    
28.                 d1(brr(j, 12)) = d1(brr(j, 12)) + temp
    
29.             End If
    
30.         End If
    
31.         If brr(j, 5) <> "" Then
    
32.             d1(brr(j, 12)) = d1(brr(j, 12)) + brr(j, 5)
    
33.         End If
    
34.     End If
    
35.    
    
36. Next
    
37. For m = 1 To UBound(crr)
    
38.     If crr(m, 14) <> "" Then
    
39.         If Not d2.exists(crr(m, 14)) Then
    
40.             If crr(m, 4) <> "" Then
    
41.                 temp = crr(m, 4)
    
42.             Else
    
43.                 d2(crr(m, 14)) = d2(crr(m, 14)) + temp
    
44. 
    
45.             End If
    
46.         End If
    
47.         If crr(m, 4) <> "" Then
    
48. 
    
49.         d2(crr(m, 14)) = d2(crr(m, 14)) + crr(m, 4)
    
50.         End If
    
51.     End If
    
52. 
    
53. Next
    
54. kr1 = d2.keys
    
55. cr1 = d2.items
    
56. 'kr = d.keys
    
57. 'cr = d.items
    
58. ReDim myarr(1 To 1000, 1 To 5)
    
59. For Each dd In d.keys
    
60.     For Each ddd In d(dd).keys
    
61.         k = k + 1
    
62.         myarr(k, 1) = dd
    
63.         myarr(k, 2) = Split(ddd, "@")(0)
    
64.         myarr(k, 3) = Split(ddd, "@")(1)
    
65.         
    
66.     Next
    
67.     For Each dd1 In d1.keys
    
68.         If dd = dd1 Then
    
69.         myarr(k, 4) = d1(dd1)
    
70.         End If
    
71.     Next
    
72.    
    
73. Next
    
74. Sheets("汇总").[a2:e5200].ClearContents
    
75. Sheets("汇总").[a2].Resize(k, 4) = myarr
    
76. MySplit1
    
77. n = Sheets("汇总").Range("d65536").End(3).Row
    
78. For i = 2 To n
    
79.     For Each dd2 In d2.keys
    
80.         If dd2 = Sheets("汇总").Cells(i, 4) Then
    
81.         Sheets("汇总").Cells(i, 5) = d2(dd2)
    
82.         End If
    
83.     Next
    
84. Next
    
85. 'MsgBox "aa"
    
86. End Sub
    
87. 
    
88. Sub MySplit1()
    
89. Dim str As String
    
90. Application.ScreenUpdating = False
    
91. 
    
92. With Sheets("汇总")
    
93.     i = .Range("a1048567").End(3).Row
    
94.     For j = 2 To i
    
95.         k = Len(Cells(j, 4)) / 9
    
96.         If k > 1 Then
    
97.             str = .Cells(j, 4)
    
98.             .Cells(j, 4) = Mid(str, 1, 9)
    
99.             For b = 1 To k - 1
    
100.             Rows(j + b).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     
101.             
     
102.             .Cells(j + b, 4) = Mid(str, b * 9 + 1, 9)
     
103.             Next
     
104.         End If
     
105.       
     
106.     Next
     
107. End With
     
108. Application.ScreenUpdating = True
     
109. End Sub
     

复制代码

自己编了个代码，效果不理想，最后一步拆分的时候不对，请老师帮忙改一下！

zjhclub

有老师帮忙回复吗？

不知道为什么

写的蛮好的啊，哪里觉得有问题可以F8查看调整啊

zjhclub

不知道为什么 发表于 2018-10-12 22:49
写的蛮好的啊，哪里觉得有问题可以F8查看调整啊

结果不对，老师能帮忙看看嘛，现在只能得到下面的结果，跟预期的有差距，谢谢！

zjhclub

自己顶一个，大师来帮忙啊！

zjhclub

自己顶，来个大师，帮忙一下，谢谢！

zjhclub

1. Sub 汇总()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. Dim str As String
   
6. Dim temp As String
   
7. arr = Sheets("采购订单").[a1].CurrentRegion.Offset(1)
   
8. brr = Sheets("采购入库").[a1].CurrentRegion.Offset(1)
   
9. crr = Sheets("销售出库").[a1].CurrentRegion.Offset(1)
   
10. For i = 1 To UBound(arr)
    
11.     If arr(i, 4) <> "" Then
    
12.         If arr(i, 5) <> "" Then
    
13.             str = arr(i, 5) & "@" & arr(i, 6)
    
14.             If Not d.exists(arr(i, 4)) Then
    
15.                 Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
    
16.             End If
    
17.             d(arr(i, 4))(str) = ""
    
18.         End If
    
19.     End If
    
20. Next
    
21. For j = 1 To UBound(brr)
    
22.    If brr(j, 12) <> "" Then
    
23.         If Not d1.exists(brr(j, 12)) Then
    
24.             If brr(j, 5) <> "" Then
    
25.                 'd1(brr(j, 7)) = d1(brr(j, 7)) + brr(j, 5)
    
26.                 temp = brr(j, 5)
    
27.             Else
    
28.                 d1(brr(j, 12)) = d1(brr(j, 12)) + temp
    
29.             End If
    
30.         End If
    
31.         If brr(j, 5) <> "" Then
    
32.             d1(brr(j, 12)) = d1(brr(j, 12)) + brr(j, 5)
    
33.         End If
    
34.     End If
    
35.    
    
36. Next
    
37. For m = 1 To UBound(crr)
    
38.     If crr(m, 14) <> "" Then
    
39.         If Not d2.exists(crr(m, 14)) Then
    
40.             If crr(m, 4) <> "" Then
    
41.                 temp = crr(m, 4)
    
42.             Else
    
43.                 d2(crr(m, 14)) = d2(crr(m, 14)) + temp
    
44. 
    
45.             End If
    
46.         End If
    
47.         If crr(m, 4) <> "" Then
    
48. 
    
49.         d2(crr(m, 14)) = d2(crr(m, 14)) + crr(m, 4)
    
50.         End If
    
51.     End If
    
52. 
    
53. Next
    
54. kr1 = d2.keys
    
55. cr1 = d2.items
    
56. 'kr = d.keys
    
57. 'cr = d.items
    
58. ReDim myarr(1 To 1000, 1 To 5)
    
59. For Each dd In d.keys
    
60.     For Each ddd In d(dd).keys
    
61.         k = k + 1
    
62.         myarr(k, 1) = dd
    
63.         myarr(k, 2) = Split(ddd, "@")(0)
    
64.         myarr(k, 3) = Split(ddd, "@")(1)
    
65.         
    
66.     Next
    
67.     For Each dd1 In d1.keys
    
68.         If dd = dd1 Then
    
69.         myarr(k, 4) = d1(dd1)
    
70.         End If
    
71.     Next
    
72.    
    
73. Next
    
74. Sheets("汇总").[a2:e5200].ClearContents
    
75. Sheets("汇总").[a2].Resize(k, 4) = myarr
    
76. MySplit1
    
77. n = Sheets("汇总").Range("d65536").End(3).Row
    
78. For i = 2 To n
    
79.     For Each dd2 In d2.keys
    
80.         If dd2 = Sheets("汇总").Cells(i, 4) Then
    
81.         Sheets("汇总").Cells(i, 5) = d2(dd2)
    
82.         End If
    
83.     Next
    
84. Next
    
85. 'MySplit2
    
86. 'MsgBox "aa"
    
87. End Sub
    
88. 
    
89. Sub MySplit1()
    
90. Dim str As String
    
91. Application.ScreenUpdating = False
    
92. 
    
93. With Sheets("汇总")
    
94.     i = .Range("a1048567").End(3).Row
    
95. a:
    
96.     For j = 2 To i
    
97.         k = Len(Cells(j, 4)) / 9
    
98.         If k > 1 Then
    
99.             str = .Cells(j, 4)
    
100.             .Cells(j, 4) = Mid(str, 1, 9)
     
101.             For b = 1 To k - 1
     
102.             Rows(j + b).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     
103.             
     
104.             .Cells(j + b, 4) = Mid(str, b * 9 + 1, 9)
     
105.             Next
     
106.         End If
     
107.         m = .Range("d1048567").End(3).Row
     
108.         If i < m Then
     
109.             i = m
     
110.             GoTo a
     
111.         End If
     
112.     Next
     
113. 
     
114.    
     
115. End With
     
116. Application.ScreenUpdating = True
     
117. End Sub
     
118. Sub MySplit2()
     
119. Dim str As String
     
120. Application.ScreenUpdating = False
     
121. 
     
122. With Sheets("汇总")
     
123.     i = .Range("a1048567").End(3).Row
     
124. 
     
125. b:
     
126.     For x = 2 To i
     
127.     k = Len(Cells(x, 5)) / 10
     
128.         If k > 1 Then
     
129.             str = .Cells(x, 5)
     
130.             .Cells(x, 5) = Mid(str, 1, 10)
     
131.             For b = 1 To k - 1
     
132.             Rows(x + b).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     
133.             
     
134.             .Cells(x + b, 5) = Mid(str, b * 10 + 1, 10)
     
135.             .Cells(x + b, 4) = Cells(x + b - 1, 4)
     
136.             Next
     
137.         End If
     
138.         m = .Range("d1048567").End(3).Row
     
139.         If i < m Then
     
140.             i = m
     
141.             GoTo b
     
142.         End If
     
143.     Next
     
144.    
     
145. End With
     
146. Application.ScreenUpdating = True
     
147. End Sub

复制代码

自己研究了半边，搞了个代码，能达到效果了，有老师能帮我改进一下吗？谢谢！