按料号整理参数

garysheep

各位大佬好，本人小白，遇到一个问题向各位老师请教。
左表是料号和参数配置，每个料号的参数条目不同。
右表是目标样式。
我想用字典和数组处理，但没有思路，理不清其中的逻辑。
请各位大佬不吝赐教。多谢！

shiruiqiang

liulang0808

Sub 按钮1_Click()
    Dim brr()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr))
    r = 0
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 1)) Then
            r = r + 1
            brr(r, 1) = arr(j, 1)
            brr(r, 2) = arr(j, 2)
            dd(arr(j, 1)) = 2
            d(arr(j, 1)) = r
        Else
            dd(arr(j, 1)) = dd(arr(j, 1)) + 1
            brr(d(arr(j, 1)), dd(arr(j, 1))) = arr(j, 2)
        End If
    Next j
    [d2].Resize(d.Count, WorksheetFunction.Max(dd.items)) = brr
End Sub

liulang0808

供参考。。。。。。。。

cyq4896

参与一下..

quqiyuan

供参考

ykcbf1100

参与一下，全表自动生成。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.17
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("Sheet1")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         arr = .Range("a1").Resize(r, 2)
   
9.     End With
   
10.     ReDim brr(1 To UBound(arr), 1 To 100)
    
11.     brr(1, 1) = arr(1, 1): brr(1, 2) = arr(1, 2)
    
12.     m = 1: n = 1
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 1)
    
15.         If Not d.exists(s) Then
    
16.             m = m + 1
    
17.             d(s) = m
    
18.             brr(m, 1) = s
    
19.         End If
    
20.         r = d(arr(i, 1))
    
21.         s = arr(i, 2)
    
22.         If Not d.exists(s) Then
    
23.             n = n + 1
    
24.             d(s) = n
    
25.         End If
    
26.         c = d(arr(i, 2))
    
27.         brr(r, c) = s
    
28.     Next
    
29.     With Sheets("Sheet2")
    
30.         .UsedRange.Clear
    
31.         .[b1].Resize(1, n - 1).Merge
    
32.         .[a1].Resize(1, n).Interior.Color = 49407
    
33.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
34.         With .[a1].Resize(m, n)
    
35.             .Value = brr
    
36.             .Borders.LineStyle = 1
    
37.             .HorizontalAlignment = xlCenter
    
38.             .VerticalAlignment = xlCenter
    
39.             With .Font
    
40.                 .Name = "微软雅黑"
    
41.                 .Size = 11
    
42.             End With
    
43.         End With
    
44.     End With
    
45.     Set d = Nothing
    
46.     MsgBox "OK！"
    
47. End Sub
    

复制代码

jjmysjg

提取A列唯一值，对应B列数据横向写入单元格。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, iColSize, vKey, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & "," & ar(i, 2)
    Next i
   
    ReDim ar(1 To dic.Count + 1, 1 To UBound(ar))
    ar(1, 1) = "料号": ar(1, 2) = "配置": r = 1
   
    For Each vKey In dic.keys
        r = r + 1
        ar(r, 1) = vKey
        br = Split(dic(vKey), ",")
        For j = 1 To UBound(br)
            ar(r, j + 1) = br(j)
        Next j
        If iColSize < UBound(br) + 1 Then iColSize = UBound(br) + 1
    Next
   
    [D1].CurrentRegion.Clear
    With [D1].Resize(UBound(br), iColSize)
        .Cells(1, 2).Resize(, iColSize - 1).Merge
         .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Rows(1).Font.Bold = True
        .Value = ar
    End With
    Application.ScreenUpdating = True
    Beep
End Sub