[已解决]如何根据条件将数据转置显示？

kangkangtianxia · 发表于 2015-1-20 21:52

如何根据单位名称及序号，将项目类型相匹配的数据转置填充到相应类型的下方？项目的类型是固定的。。结果详见sheet“目标结果”
谢谢

最佳答案

芐雨

2015-1-20 22:24

本帖最后由芐雨于 2015-1-21 09:21 编辑

Sub 按钮2_Click()
Dim arr, brr, crr, i&, j&, x&, s
Dim dic As Object, d As Object
arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row) 'D列记为数组arr
brr = Sheets("目标结果").Range("A1").CurrentRegion '记为数组brr
Set d = CreateObject("scripting.dictionary") '创建字典d
Set dic = CreateObject("scripting.dictionary") '创建字典dic
For i = 3 To UBound(brr, 2) '遍历，得到类型
d(brr(1, i)) = i '放入字典，通过字典返加列数
Next
ReDim crr(1 To 1000, 1 To UBound(brr, 2))
For i = 1 To UBound(arr) ' 遍历arr
s = arr(i, 1) & "|" & arr(i, 2) '单位名称与序号，记为s，区分标准
If dic.exists(s) Then '判断是否存在
crr(dic(s), d(arr(i, 3))) = arr(i, 4) + crr(dic(s), d(arr(i, 3))) 'd(arr(i, 3))返列数，dic(s)返回行数
Else
x = x + 1 '计数
dic(s) = x 'dic(s)返回行数
crr(x, 1) = arr(i, 1) '名称
crr(x, 2) = arr(i, 2) '序号
crr(x, d(arr(i, 3))) = arr(i, 4) '数值，d(arr(i, 3))返列数
End If
Next
With Sheets("目标结果")
.UsedRange.Offset(1).Clear '单元格区域向下偏移一行
.[B:B].NumberFormat = "@" '文本格式
.Range("A2").Resize(x, UBound(crr, 2)) = crr '赋值
.Range("A2").Resize(x, UBound(crr, 2)).Borders.LineStyle = 1 '边框
.Select
End With
MsgBox "完成"
End Sub

复制代码

kangkangtianxia · 发表于 2015-1-20 21:53

忘了附件。。

芐雨 · 发表于 2015-1-20 22:24

本帖最后由芐雨于 2015-1-21 09:21 编辑

Sub 按钮2_Click()
Dim arr, brr, crr, i&, j&, x&, s
Dim dic As Object, d As Object
arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row) 'D列记为数组arr
brr = Sheets("目标结果").Range("A1").CurrentRegion '记为数组brr
Set d = CreateObject("scripting.dictionary") '创建字典d
Set dic = CreateObject("scripting.dictionary") '创建字典dic
For i = 3 To UBound(brr, 2) '遍历，得到类型
d(brr(1, i)) = i '放入字典，通过字典返加列数
Next
ReDim crr(1 To 1000, 1 To UBound(brr, 2))
For i = 1 To UBound(arr) ' 遍历arr
s = arr(i, 1) & "|" & arr(i, 2) '单位名称与序号，记为s，区分标准
If dic.exists(s) Then '判断是否存在
crr(dic(s), d(arr(i, 3))) = arr(i, 4) + crr(dic(s), d(arr(i, 3))) 'd(arr(i, 3))返列数，dic(s)返回行数
Else
x = x + 1 '计数
dic(s) = x 'dic(s)返回行数
crr(x, 1) = arr(i, 1) '名称
crr(x, 2) = arr(i, 2) '序号
crr(x, d(arr(i, 3))) = arr(i, 4) '数值，d(arr(i, 3))返列数
End If
Next
With Sheets("目标结果")
.UsedRange.Offset(1).Clear '单元格区域向下偏移一行
.[B:B].NumberFormat = "@" '文本格式
.Range("A2").Resize(x, UBound(crr, 2)) = crr '赋值
.Range("A2").Resize(x, UBound(crr, 2)).Borders.LineStyle = 1 '边框
.Select
End With
MsgBox "完成"
End Sub

复制代码

kangkangtianxia · 发表于 2015-1-21 08:54

芐雨发表于 2015-1-20 22:24

谢谢帮忙！能附上个中文解析吗？

芐雨 · 发表于 2015-1-21 09:22

kangkangtianxia 发表于 2015-1-21 08:54
谢谢帮忙！能附上个中文解析吗？

已更新，但附件不能用，再传一份吧

kangkangtianxia · 发表于 2015-1-21 11:22

芐雨发表于 2015-1-21 09:22
已更新，但附件不能用，再传一份吧

谢谢！！

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