数据格式转换

wqhsz385919

baofa2 发表于 2024-5-18 12:07

结果非常OK,谢谢！

sxbjzjf110

Sub Test()     Dim d As Object, Ar, i, j, n, s     Dim sht As Worksheet     Set d = CreateObject("Scripting.Dictionary")     Set sht = Sheets("工艺路线 (整理版)表一")     br = Array(1, 3, 4, 5, 8)     Ar = sht.Range("A1").CurrentRegion     For i = 2 To UBound(Ar)         If Not d.Exists(Ar(i, 2)) Then             d(Ar(i, 2)) = Array(Ar(1, 1), Ar(1, 3), Ar(1, 4), Ar(1, 5), Ar(1, 8))         End If     Next     n = 19     With Sheets("模拟的结果")         For Each m In d.keys             For i = 2 To UBound(Ar)                 If Ar(i, 2) = m Then                     s = s + 1                     .Cells(n, 1) = m                     For j = 0 To 4                         .Cells(n + j, 2) = d(m)(j)                         .Cells(n + j, 2 + s) = Ar(i, br(j))                     Next                 End If             Next             s = 0             n = n + 5             .Range("A" & n - 5, "A" & n - 1).Merge         Next     End With End Sub

sxbjzjf110

usedrange

参与

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, brr, m%, i%, j%, sh, r%, c%, k
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheet3
   
5.         m = .Range("a1").End(4).Row
   
6.         Set sh = .Range("a1:h" & m)
   
7.         sh.Sort key1:="出货料号", order1:=1, Header:=xlYes
   
8.         arr = .Range("A1").CurrentRegion
   
9.         ReDim brr(1 To 10000, 1 To 20)
   
10.         For i = 2 To UBound(arr)
    
11.             For j = 1 To 8
    
12.                 If j <> 2 And j <> 6 And j <> 7 Then
    
13.                     dic(j & "|" & arr(i, 2) & "|" & arr(1, j)) = dic(j & "|" & arr(i, 2) & "|" & arr(1, j)) & "|" & arr(i, j)
    
14.                 End If
    
15.             Next j
    
16.         Next i
    
17.         r = 1
    
18.         For Each k In dic.keys
    
19.             t = Split(dic(k), "|")
    
20.             brr(r, 1) = Split(k, "|")(1)
    
21.             brr(r, 2) = Split(k, "|")(2)
    
22.             For i = 1 To UBound(t)
    
23.                 brr(r, i + 2) = t(i)
    
24.             Next i
    
25.             r = r + 1
    
26.         Next k
    
27.         With Sheet1
    
28.             .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
29.             Application.DisplayAlerts = False
    
30.             m = .[a2].End(4).Row
    
31.             .Range("a1:q" & m).Borders.LineStyle = 1
    
32.             .Range("a1:q" & m).Columns.AutoFit
    
33.             .[a1] = "来自于客户的初始信息": .[a1:b1].Merge
    
34.             .[c1] = "工站生产计划": .[c1:q1].Merge
    
35.             For i = 2 To m Step 5
    
36.                 Sheet1.Range("a" & i).Resize(5, 1).Merge
    
37.             Next i
    
38.             Application.DisplayAlerts = True
    
39.         End With
    
40.     End With
    
41.     Set dic = Nothing
    
42. End Sub
    

复制代码