[已解决]用VBA实现数据转置的问题，谢谢了

maysh2009

大侠们帮帮忙啊，需要将左边B-D列的结果转置，将D列不等于C列的值转置，谢谢大家了，谢谢！

上一点数据（附件是全部数据），

BSC	CELL		DCHNO			输出格式
JMM10B1	JMJSHN9	43	9		JMJSHN9	9	24	65
JMM10B1	JMJSHN9	43	24		JMJYSL8	3	91	11
JMM10B1	JMJSHN9	43	43		JMJJYT9
JMM10B1	JMJSHN9	43	65
JMM10B1	JMJYSL8	14	3				大侠们帮帮忙啊，需要将左边B-D列的结果转置，将D列不等于C列的值转置，谢谢大家了，谢谢！
JMM10B1	JMJYSL8	14	14
JMM10B1	JMJYSL8	14	91
JMM10B1	JMJYSL8	14	11
JMM10B1	JMJJYT9	36	3
JMM10B1	JMJJYT9	36	36
JMM10B1	JMJJYT9	36	66
JMM10B1	JMJJYT9	36	16
JMM10B1	JDJFLD3	515	515
JMM10B1	JDJFLD3	515	538
JMM10B1	JDJFLD3	515	544
JMM10B1	JDJFLD3	515	560
JMM10B1	JDJFLD3	515	564
JMM10B1	JDJFLD3	515	597

VBA实现数据转置 .rar (73.81 KB, 下载次数: 38)

2012-3-31 17:41 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-3-31 18:13

看下效果：

1. 
   
2. Sub JustTest()
   
3.     Dim D As New Dictionary, Arr, i&, ArrR(1 To 60000, 1 To 200), k&, Ar()
   
4.     Arr = Range("b2:d" & Cells(Rows.Count, 1).End(3).Row).Value
   
5.     For i = 1 To UBound(Arr)
   
6.         If Arr(i, 2) <> Arr(i, 3) Then
   
7.             If D.Exists(Arr(i, 1)) Then
   
8.                 Ar(D(Arr(i, 1))) = Ar(D(Arr(i, 1))) + 1
   
9.                 ArrR(D(Arr(i, 1)), Ar(D(Arr(i, 1)))) = Arr(i, 3)
   
10.             Else
    
11.                 k = k + 1: D.Add Arr(i, 1), k
    
12.                 ReDim Preserve Ar(1 To k): Ar(k) = 2
    
13.                 ArrR(k, 1) = Arr(i, 1): ArrR(k, 2) = Arr(i, 3)
    
14.             End If
    
15.         End If
    
16.     Next i
    
17.     Application.ScreenUpdating = False
    
18.     Range([f2], Cells(Rows.Count, Columns.Count)).ClearContents
    
19.     [f2].Resize(k, Application.Max(Ar)) = ArrR
    
20.     Application.ScreenUpdating = True
    
21.     Set D = Nothing
    
22.     MsgBox "处理完毕！"
    
23. End Sub
    

复制代码

VBA实现数据转置 .rar (104.55 KB, 下载次数: 197)

2012-3-31 18:13 上传

点击文件名下载附件

跳转到最佳答案楼层

liuguansky

看下效果：

1. 
   
2. Sub JustTest()
   
3.     Dim D As New Dictionary, Arr, i&, ArrR(1 To 60000, 1 To 200), k&, Ar()
   
4.     Arr = Range("b2:d" & Cells(Rows.Count, 1).End(3).Row).Value
   
5.     For i = 1 To UBound(Arr)
   
6.         If Arr(i, 2) <> Arr(i, 3) Then
   
7.             If D.Exists(Arr(i, 1)) Then
   
8.                 Ar(D(Arr(i, 1))) = Ar(D(Arr(i, 1))) + 1
   
9.                 ArrR(D(Arr(i, 1)), Ar(D(Arr(i, 1)))) = Arr(i, 3)
   
10.             Else
    
11.                 k = k + 1: D.Add Arr(i, 1), k
    
12.                 ReDim Preserve Ar(1 To k): Ar(k) = 2
    
13.                 ArrR(k, 1) = Arr(i, 1): ArrR(k, 2) = Arr(i, 3)
    
14.             End If
    
15.         End If
    
16.     Next i
    
17.     Application.ScreenUpdating = False
    
18.     Range([f2], Cells(Rows.Count, Columns.Count)).ClearContents
    
19.     [f2].Resize(k, Application.Max(Ar)) = ArrR
    
20.     Application.ScreenUpdating = True
    
21.     Set D = Nothing
    
22.     MsgBox "处理完毕！"
    
23. End Sub
    

复制代码

VBA实现数据转置 .rar (104.55 KB, 下载次数: 197)

2012-3-31 18:13 上传

点击文件名下载附件

maysh2009

liuguansky 发表于 2012-3-31 18:13
看下效果：

谢谢版主，就是这样的

ljw7821

应该用Application.WorksheetFunction.Transpose吧

maysh2009

ljw7821 发表于 2012-3-31 18:27
应该用Application.WorksheetFunction.Transpose吧

你有更加好的办法？