求助老师们答疑数据表转置

admin122333

老师们帮忙看看数据表转置

shiruiqiang

ykcbf1100

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.2.17
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set d2 = CreateObject("Scripting.Dictionary")
   
6.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
7.     arr = Me.Range("a1:d" & r)
   
8.     ReDim brr(1 To UBound(arr), 1 To 2)
   
9.     For i = 3 To UBound(arr)
   
10.         s = arr(i, 1)
    
11.         If Not d1.exists(s) Then
    
12.             d1(s) = Array(arr(i, 1), arr(i, 2))
    
13.         Else
    
14.             t = d1(s)
    
15.             t(1) = IIf(InStr(t(1), arr(i, 2)), t(1), t(1) & "、" & arr(i, 2))
    
16.             d1(s) = t
    
17.         End If
    
18.         For j = 1 To UBound(arr, 2)
    
19.             k = arr(i, 4)
    
20.             d2(k) = ""
    
21.             s = arr(i, 1) & "|" & arr(i, 4)
    
22.             d(s) = d(s) + arr(i, 3)
    
23.         Next
    
24.     Next
    
25.     t = d1.items
    
26.     For Each k In d1.keys
    
27.         m = m + 1
    
28.         brr(m, 1) = d1(k)(0)
    
29.         brr(m, 2) = d1(k)(1)
    
30.     Next
    
31.     Me.[g3:z1000] = ""
    
32.     Me.[i3].Resize(1, 20) = ""
    
33.     Me.[g3].Resize(m, 2) = brr
    
34.     Me.[i2].Resize(1, d2.Count) = d2.keys
    
35.     arr = Me.[g2].Resize(m + 1, d2.Count + 2)
    
36.     For i = 2 To UBound(arr)
    
37.         For j = 3 To UBound(arr, 2)
    
38.             s = arr(i, 1) & "|" & arr(1, j)
    
39.             If d.exists(s) Then
    
40.                 arr(i, j) = d(s)
    
41.             End If
    
42.         Next
    
43.     Next
    
44.     Me.[g2].Resize(m + 1, d2.Count + 2) = arr
    
45.     Set d = Nothing
    
46.     Set d1 = Nothing
    
47.     Set d2 = Nothing
    
48.     Application.ScreenUpdating = False
    
49.     MsgBox "OK！"
    
50. End Sub
    

复制代码

sxbjzjf110

参与一下。。。。。

fzxba

测试.zip (29.58 KB, 下载次数: 17)

2024-2-18 09:16 上传

点击文件名下载附件

笨鸟飞不高

工作簿2.zip (23.4 KB, 下载次数: 11)

2024-2-18 13:16 上传

点击文件名下载附件

admin122333

shiruiqiang 发表于 2024-2-17 18:59

谢谢老师的教导,谢谢

admin122333

ykcbf1100 发表于 2024-2-17 21:03
代码供参考。。。

谢谢老师的教导,谢谢

admin122333

sxbjzjf110 发表于 2024-2-17 21:05
参与一下。。。。。

谢谢老师,谢谢