请教表头去重复内容对应转置的代码

鄂龙蒙

请教：附件中左边是原数据表（列数不定），想通过代码实现右边的结果表样。谢谢！
请教表头去重复内容对应转置的代码.rar (7.92 KB, 下载次数: 29)

2017-6-4 12:35 上传

点击文件名下载附件

ɑ。凱

仅供参考，初学者，不是很规范
Sub test()
Dim arr()
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Rng = Range("a1").CurrentRegion
    For i = 1 To UBound(Rng, 2)
        d(Rng(2, i) & "@" & Rng(3, i) & "@" & Rng(4, i)) = ""
        d2(Rng(5, i)) = ""
        ReDim arr(1 To d2.Count + 3, 1 To d.Count)
    Next
k = d.keys: k2 = d2.keys
'Debug.Print d.Count & k(1)
    For i = 1 To d.Count
        For j = 1 To 3
            arr(j, i) = Split(k(i - 1), "@")(j - 1)
        Next
    Next
  For j = 4 To d2.Count + 2
      arr(j, 1) = k2(j - 3)
  Next
For r = 4 To UBound(arr)
    For c = 2 To UBound(arr, 2)
        For rc = 2 To UBound(Rng, 2)
            If arr(1, c) & arr(r, 1) = Rng(2, rc) & Rng(5, rc) Then
            arr(r, c) = Rng(6, rc)
            End If
        Next
    Next
Next
[H1].Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub

ɑ。凱

附件。。。。

蓝桥玄霜

请见代码。

ɑ。凱

学习了，蓝桥老师的代码更精妙，减少了很多的循环步骤，巧妙的用了字典的ITEMS记录了重复的列数和重复次数

Vicel

支持同材料名称而多材料规格
Sub test()
    Dim d As Object, ar, br, cr(), dr, i&, j&, m&, n&
    Set d = CreateObject("scripting.dictionary")
    ar = [A1].CurrentRegion
    d("项目") = ",材料编号,材料名称,材料规格"
    For i = 2 To UBound(ar, 2)
        If ar(2, i) <> "" Then
            If InStr(d("项目") & ",", "," & ar(5, i) & ",") = 0 Then d("项目") = d("项目") & "," & ar(5, i)
            If Not d.exists(ar(2, i) & "," & ar(3, i) & "," & ar(4, i)) Then
                d(ar(2, i) & "," & ar(3, i) & "," & ar(4, i)) = ar(5, i) & "," & ar(6, i)
            Else
                d(ar(2, i) & "," & ar(3, i) & "," & ar(4, i)) = d(ar(2, i) & "," & ar(3, i) & "," & ar(4, i)) & ":" & ar(5, i) & "," & ar(6, i)
            End If
        End If
    Next i
    n = 1: m = UBound(ar)
    br = Split(d("项目"), ","): ar = d.keys
    ReDim cr(1 To UBound(br), 1 To d.Count)
    For i = 1 To UBound(br)
        cr(i, 1) = br(i)
        If i > 3 Then d(br(i)) = i
    Next i
    For i = LBound(ar) To UBound(ar)
        If ar(i) <> "项目" Then
            n = n + 1
            br = Split(ar(i), ",")
            For j = LBound(br) To UBound(br)
                cr(j + 1, n) = br(j)
            Next j
            br = Split(d(ar(i)), ":")
            For j = LBound(br) To UBound(br)
                dr = Split(br(j), ",")
                cr(d(dr(0)), n) = dr(1)
            Next j
        End If
    Next i
    Range("A" & m + 2).Resize(UBound(cr), UBound(cr, 2)) = cr
    Set d = Nothing
End Sub