数据转置

jiajayshi

求助，上图是每个平台对应的城市，我想把这个数据转成下图，每个城市对应的平台

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     arr = Sheets(1).UsedRange
   
5.     For j = 2 To UBound(arr)
   
6.         If Len(arr(j, 1)) > 0 And VBA.IsNumeric(arr(j, 1)) Then
   
7.             For i = 5 To UBound(arr, 2)
   
8.                 If Len(arr(j, i)) > 0 Then
   
9.                     d(arr(j, i)) = d(arr(j, i)) & "," & arr(j, 2)
   
10.                 End If
    
11.             Next i
    
12.         End If
    
13.     Next j
    
14.     For j = 0 To d.Count - 1
    
15.         Cells(j + 4, 1) = j + 1
    
16.         Cells(j + 4, 2) = d.keys()(j)
    
17.         brr = Split(d.items()(j), ",")
    
18.         Cells(j + 4, 4).Resize(1, UBound(brr) + 1) = brr
    
19.     Next j
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
   
9.     arr = .Range("a4").Resize(r - 3, c)
   
10.   End With
    
11.   For i = 1 To UBound(arr)
    
12.     For j = 5 To UBound(arr, 2)
    
13.       If Len(arr(i, j)) <> 0 Then
    
14.         If Not d.exists(arr(i, j)) Then
    
15.           m = 1
    
16.           ReDim brr(1 To m)
    
17.         Else
    
18.           brr = d(arr(i, j))
    
19.           m = UBound(brr) + 1
    
20.           ReDim Preserve brr(1 To m)
    
21.         End If
    
22.         brr(m) = arr(i, 2)
    
23.         d(arr(i, j)) = brr
    
24.       End If
    
25.     Next
    
26.   Next
    
27.   With Worksheets("sheet2")
    
28.     m = 4
    
29.     For Each aa In d.keys
    
30.       brr = d(aa)
    
31.       .Cells(m, 1) = m - 3
    
32.       .Cells(m, 2) = aa
    
33.       .Cells(m, 5).Resize(1, UBound(brr)) = brr
    
34.       m = m + 1
    
35.     Next
    
36.   End With
    
37. End Sub
    

复制代码

chxw68

详见附件。

grf1973

请看附件。。。

micch

这个转置，同一个城市对应多个 X XX，那么结果的C:D列放哪个？？
写一个不合并后split的，C:D列放城市第一出现时平台对应的CD列x,xx

1. Sub test()
   
2.     arr = Sheet1.UsedRange
   
3.     u = UBound(arr)
   
4.     ReDim brr(1 To 999, 1 To u)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 4 To u
   
7.     For k = 5 To UBound(arr, 2)
   
8.                 If Len(arr(i, k)) > 0 And arr(i, 2) <> "" Then
   
9.                             If d.exists(arr(i, k)) Then
   
10.                                     c = d(arr(i, k))
    
11.                                     brr(c, u) = brr(c, u) + 1
    
12.                                     brr(c, brr(c, u)) = arr(i, 2)
    
13.                             Else
    
14.                                     r = r + 1
    
15.                                     d(arr(i, k)) = r
    
16.                                     brr(r, 1) = r
    
17.                                     brr(r, 2) = arr(i, k)
    
18.                                     brr(r, 3) = arr(i, 3)
    
19.                                     brr(r, 4) = arr(i, 4)
    
20.                                     brr(r, 5) = arr(i, 2)
    
21.                                     brr(r, u) = 5
    
22.                             End If
    
23.                 End If
    
24.     Next k, i
    
25.     Sheet2.[4:99].Clear
    
26.     Sheet2.[a4].Resize(r, u - 1) = brr
    
27. End Sub

复制代码

jiajayshi

grf1973 发表于 2020-2-25 16:43
请看附件。。。

问一下最后输入的时候mid(d(x),2)     d的item为什么前面有个空白

jiajayshi

liulang0808 发表于 2020-2-25 16:33

谢谢你，非常感谢。

jiajayshi

micch 发表于 2020-2-25 17:47
这个转置，同一个城市对应多个 X XX，那么结果的C:D列放哪个？？
写一个不合并后split的，C:D列放城市第一 ...

谢谢你，非常感谢。