数据转换，要求见截图（较急）

chxw68 · 发表于 2020-1-20 15:40

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:e" & r)
n = 1
For i = 1 To UBound(arr)
If Not d1.exists(arr(i, 5)) Then
n = n + 1
d1(arr(i, 5)) = n
End If
Next
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 4)) Then
ReDim brr(1 To d1.Count + 1)
brr(1) = arr(i, 4)
Else
brr = d(arr(i, 4))
End If
n = d1(arr(i, 5))
If IsEmpty(brr(n)) Then
brr(n) = arr(i, 2)
Else
brr(n) = arr(i, 2) & "、" & arr(i, 2)
End If
d(arr(i, 4)) = brr
Next
End With
With Worksheets("sheet2")
.Cells.Clear
.Range("a1") = "班级"
.Range("b1").Resize(1, d1.Count) = d1.keys
.Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
With .Range("a1").Resize(1, UBound(brr))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Range("a1").Resize(1 + d.Count, UBound(brr))
.Borders.LineStyle = xlContinuous
End With
End With
End Sub

复制代码

chxw68 · 发表于 2020-1-20 15:41

详见附件。

szqhb · 发表于 2020-1-22 21:18

zpy2 发表于 2020-1-20 13:12
也可以用Sql语句查询一下。。。

谢谢，祝你新年快乐！身体健康！万事如意！

szqhb · 发表于 2020-1-22 21:19

chxw68 发表于 2020-1-20 15:41
详见附件。

谢谢，祝你新年快乐！身体健康！万事如意！

szqhb · 发表于 2022-4-6 22:35

chxw68 发表于 2020-1-20 15:41
详见附件。

晚上好！就要用到附件转换数据，发现代码转换的数据不对（每班显示同一人）。

mafect · 发表于 2022-4-7 06:24

感谢分享，学习

chxw68 · 发表于 2022-4-7 14:25

2年半后才发现错误，第一次遇到。

cjc209 · 发表于 2022-4-7 16:50

我来一个数据透视参数化的

szqhb · 发表于 2022-4-11 11:31

cjc209 发表于 2022-4-7 16:50
我来一个数据透视参数化的

谢谢你！非常感谢

szqhb · 发表于 2022-4-11 11:38

chxw68 发表于 2022-4-7 14:25
2年半后才发现错误，第一次遇到。

万分感谢！
实在不好意思，即将实体开学，近日又要将打印奖状的数据源转换成所需格式进行PPt展示，使用时才发现问题（往年用土法完成了

）

		自动登录	找回密码
密码			免费注册

[求助] 数据转换，要求见截图（较急）