重新排列的问题，感谢各位高手！

tzexcelhome

ykcbf1100 发表于 2024-3-19 21:51
附件中没有编码啊

老师，已经上传附件，请查收！


还有第二个问题：就是对于配件没有进行去重，就是说很多成品代码包含相同重复的零部件的。

tzexcelhome

fzxba 发表于 2024-3-14 20:48

老师，您的编码测试了，发现有问题：
1、如果成品编码是文本格式，代码会出问题
2、很多配件是相同的，需要先去重。

具体详见附件有模拟数据，感谢

ykcbf1100

tzexcelhome 发表于 2024-3-19 22:16
老师，已经上传附件，请查收！

改好了。。。

ykcbf1100

附上代码。。。

1. Sub ykcbf()   '//2024.3.20
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set d2 = CreateObject("Scripting.Dictionary")
   
7.     With Sheets("原始")
   
8.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
9.         arr = .[a1].Resize(r, 4)
   
10.     End With
    
11.     For i = 2 To UBound(arr)
    
12.         s = arr(i, 1)
    
13.         d1(s) = ""
    
14.         s = arr(i, 2) & "|" & arr(i, 3)
    
15.         d2(s) = ""
    
16.         s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 1)
    
17.         d(s) = arr(i, 4)
    
18.     Next
    
19.     t = d.items
    
20.     ReDim brr(1 To d2.Count, 1 To 2)
    
21.     For Each k In d2.keys
    
22.         If k <> Empty Then
    
23.             m = m + 1
    
24.             brr(m, 1) = Split(k, "|")(0)
    
25.             brr(m, 2) = Split(k, "|")(1)
    
26.         End If
    
27.     Next
    
28.     With Sheets("目的")
    
29.         .UsedRange.Offset(1, 2).ClearContents
    
30.         .Rows(1).NumberFormatLocal = "@"
    
31.         .[c1].Resize(1, d1.Count) = d1.keys
    
32.         .[a2].Resize(m, 2) = brr
    
33.         arr = .[a1].Resize(m + 1, 2 + d1.Count)
    
34.         For i = 2 To UBound(arr)
    
35.             For j = 3 To UBound(arr, 2)
    
36.                 s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(1, j)
    
37.                 If d.Exists(s) Then
    
38.                     arr(i, j) = d(s)
    
39.                 End If
    
40.             Next
    
41.         Next
    
42.         .Columns(1).NumberFormatLocal = "@"
    
43.         .[a1].Resize(m + 1, 2 + d1.Count) = arr
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    
49. 
    

复制代码

fzxba

tzexcelhome 发表于 2024-3-19 22:35
老师，您的编码测试了，发现有问题：
1、如果成品编码是文本格式，代码会出问题
2、很多配件是相同的， ...

1. Option Explicit
   
2. 
   
3. Sub test1() '
   
4. 
   
5.   Dim Conn As Object, rs As Object, SQL As String, i As Integer
   
6.   
   
7.   Set Conn = CreateObject("ADODB.Connection")
   
8.   Set rs = CreateObject("ADODB.Recordset")
   
9.   
   
10.   If Application.Version < 12 Then
    
11.     Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    
12.   Else
    
13.     Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    
14.   End If
    
15.   
    
16.   
    
17.   SQL = "TRANSFORM SUM(累计用量) SELECT 子件编码,子件名称 FROM [Sheet1$] WHERE LEN([母件编码(PInvCode)H])>0 GROUP BY 子件编码,子件名称 PIVOT [母件编码(PInvCode)H]"
    
18.   
    
19.   rs.Open SQL, Conn, 1, 3
    
20.   
    
21.   With Range("G1")
    
22.   .CurrentRegion.ClearContents
    
23.     For i = 0 To rs.Fields.Count - 1
    
24.       .Offset(0, i).NumberFormatLocal = "@"
    
25.       .Offset(0, i) = rs.Fields(i).Name
    
26.     Next
    
27.     .Offset(1).CopyFromRecordset rs
    
28.   End With
    
29.   
    
30.   rs.Close
    
31.   Set rs = Nothing
    
32.   Conn.Close
    
33.   Set Conn = Nothing
    
34.   
    
35. End Sub

复制代码

fzxba

tzexcelhome 发表于 2024-3-19 22:35
老师，您的编码测试了，发现有问题：
1、如果成品编码是文本格式，代码会出问题
2、很多配件是相同的， ...

审_见附件.zip (116.41 KB, 下载次数: 4)

2024-3-20 08:11 上传

点击文件名下载附件

tzexcelhome

ykcbf1100 发表于 2024-3-20 07:37
改好了。。。

谢谢尊敬的侠圣，非常强大好用的代码，万分感谢！

tzexcelhome

fzxba 发表于 2024-3-20 08:11

感谢您的支持，谢谢！

tzexcelhome

ykcbf1100 发表于 2024-3-20 07:38
附上代码。。。

老师，您好！这个代码碰到一个小问题：就是在一个产品bom里，如果有两个相同的子建编码，那么在计算的时候不能够进行相加。请查看附件！

ykcbf1100

tzexcelhome 发表于 2024-3-30 21:29
老师，您好！这个代码碰到一个小问题：就是在一个产品bom里，如果有两个相同的子建编码，那么在计算的时 ...

你再试一下。