有關行列轉置問題

jacky007x

老師好，有關行列轉置問題要請教老師們，效果如附件

例如
1.B列裡有重複的表面處理、熱處理等項目，在P列裡只需要唯一值，如：

表面处理

熱處理

外加工

机加工

热处理

2.然後將P列裡的值作為條件，並查找E列的值後，於Q列橫向列出相關的唯一值，如

表面处理

电镀

煲黑

电泳

鋁氧化

烤漆

目前是不曉得該怎麼做才能運行第2點，請老師們多多指導!!

paciguard

没看懂，是要每一列都去重吗？？

jiangxiaoyun

看不明白，路过拿分

jacky007x

paciguard 发表于 2017-9-21 19:32
没看懂，是要每一列都去重吗？？

老師您好，就是首先要將B列的資料取不重複值到P列
再依照P列的條件從E列取出取出不重複值，並依序排列在Q、R、S、T、U列裡(可能會到AA列)
再勞煩老師指導一下了，感謝!!

jacky007x

jiangxiaoyun 发表于 2017-9-21 19:32
看不明白，路过拿分

老師您好，就是首先要將B列的資料取不重複值到P列
再依照P列的條件從E列取出取出不重複值，並依序排列在Q、R、S、T、U列裡(可能會到AA列)
再勞煩老師指導一下了，感謝!!

jacky007x

paciguard 发表于 2017-9-21 19:32
没看懂，是要每一列都去重吗？？

例如
B列裡有重複的表面處理、熱處理等項目，在P列裡只需要唯一值，如：

表面处理

熱處理

外加工

机加工

热处理

然後將P列裡的值作為條件，並查找E列的值後，於Q列橫向列出相關的唯一值，如

表面处理

电镀

煲黑

电泳

鋁氧化

烤漆

jacky007x

大神們，老師們再麻煩幫忙一下了，感激不盡

活在理想的世界

1. Sub d()
   
2. Dim Dic As Object, Eic As Object, arr(), brr(), w As WorksheetFunction
   
3. Set w = WorksheetFunction
   
4. Set Dic = CreateObject("Scripting.Dictionary")
   
5. Set Eic = CreateObject("Scripting.Dictionary")
   
6. k = Range("a1048576").End(3).Row - 1
   
7. h = Range("a1").End(2).Column
   
8. arr = Range("a2").Resize(k, h)
   
9. For i = 1 To UBound(arr)
   
10.     Dic(arr(i, 2)) = Dic(arr(i, 2)) & "*" & arr(i, 5)
    
11. Next
    
12. For Each i In Dic.Items
    
13. b = b + 1
    
14.     x = UBound(Split(i, "*"))
    
15.     a = 0
    
16.     ReDim Preserve brr(1 To 1, 1 To x)
    
17.     Eic.RemoveAll
    
18.     For j = 1 To UBound(brr, 2)
    
19.         a = a + 1
    
20.         brr(1, a) = Split(i, "*")(a)
    
21.         If brr(1, a) <> "" Then
    
22.             Eic(brr(1, a)) = ""
    
23.         End If
    
24.     Next
    
25.     Range("q" & b).Resize(1, Eic.Count) = Eic.Keys
    
26. Next
    
27. Range("p1").Resize(Dic.Count, 1) = w.Transpose(Dic.Keys)
    
28. End Sub

复制代码

uynayna

1. Sub Test()
   
2.     Dim d As Object, d1, ar, br, k, i&, m%, n%
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     ar = Sheets("sheet1").UsedRange
   
6.     For i = 2 To UBound(ar)
   
7.         If Not d.Exists(ar(i, 2)) Then
   
8.             d(ar(i, 2)) = ""
   
9.         End If
   
10.     Next
    
11.     ReDim br(1 To d.Count, 1 To UBound(ar))
    
12.     For Each aa In d.keys
    
13.         k = k + 1
    
14.         n = 1
    
15.         For i = 2 To UBound(ar)
    
16.             If ar(i, 2) = aa Then
    
17.                 If Not d1.Exists(ar(i, 5)) Then
    
18.                     d1(ar(i, 5)) = ""
    
19.                     n = n + 1
    
20.                     br(k, 1) = ar(i, 2)
    
21.                     br(k, n) = ar(i, 5)
    
22.                 End If
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     Sheets("sheet1").Range("p1").Resize(d.Count, UBound(br, 2)) = br
    
27. End Sub

复制代码

jiangxiaoyun

1. Sub vv()
   
2.     Dim arr
   
3.     arr = Range("b2", [e1024768].End(3))
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         If Not d.exists(arr(i, 1)) Then
   
7.             d(arr(i, 1)) = arr(i, 4)
   
8.         Else
   
9.             If InStr(d(arr(i, 1)), arr(i, 4)) = 0 Then
   
10.                 d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 4)
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     [p1].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
15.     Range("q1").Resize(d.Count, 1).TextToColumns comma:=True
    
16. End Sub
    

复制代码