求vba大神帮助-excel数据转置的问题

xueyushenl

求解：如何把以下的格式
列1   列2           列3
110   AJ-1          5
110   AJ-2          89
110   AJ1-name   璃
110   AJ2-name   一
110   AJ1-value  3
110   AJ2-value  4
转换成如下边格式

示例

实际上数据不止110，更有120、130、140等等。

windimi007

上传附件，please！

xueyushenl

windimi007 发表于 2013-11-28 16:08
上传附件，please！

就是这个。

windimi007

xueyushenl 发表于 2013-11-28 17:35
就是这个。

不知道是不是这个意思？请测试！

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim ar, br(1 To 1000, 1 To 100)
   
4.     Dim i As Long, j As Long, k As Long, cl As Long
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Sheet1.Cells(1, 1).CurrentRegion
   
7.     For i = 2 To UBound(ar)
   
8.         If d.exists(ar(i, 1)) Then
   
9.             d(ar(i, 1)) = Array(d(ar(i, 1))(0), d(ar(i, 1))(1) + 1)
   
10.             cl = d(ar(i, 1))(1)
    
11.             If cl > k Then k = cl
    
12.             br(d(ar(i, 1))(0) * 2 - 1, cl) = ar(i, 2)
    
13.             br(d(ar(i, 1))(0) * 2, cl) = ar(i, 4)
    
14.         Else
    
15.             j = j + 1
    
16.             d.Add ar(i, 1), Array(j, 2)
    
17.             br(j * 2 - 1, 1) = "对象"
    
18.             br(j * 2, 1) = ar(i, 1)
    
19.             br(j * 2 - 1, 2) = ar(i, 2)
    
20.             br(j * 2, 2) = ar(i, 4)
    
21.         End If
    
22.     Next i
    
23.     With Sheet2
    
24.         .Cells.Clear
    
25.         .Cells(1, 1).Resize(j, k) = br
    
26.         .Cells.EntireColumn.AutoFit
    
27.     End With
    
28. End Sub

复制代码

xueyushenl

windimi007 发表于 2013-11-28 17:51
不知道是不是这个意思？请测试！

谢谢大神，大概是这样子的，只不过不让他每一条数据都跟一行标题行了。就是第一行和第二行不变，从第三行开始输出数据其他的不同编码接着往下依次罗列。

windimi007

xueyushenl 发表于 2013-11-29 08:38
谢谢大神，大概是这样子的，只不过不让他每一条数据都跟一行标题行了。就是第一行和第二行不变，从第三 ...

请测试！

1. Sub test()
   
2.     Dim dr As Object, dc As Object
   
3.     Dim ar, br, cr(1 To 10000, 1 To 21)
   
4.     Dim i As Long, j As Long
   
5.     Set dr = CreateObject("scripting.dictionary")
   
6.     Set dc = CreateObject("scripting.dictionary")
   
7.     ar = Sheet1.Cells(1, 1).CurrentRegion
   
8.     br = Sheet2.Range("A2:U2")
   
9.     For i = 1 To UBound(br, 2)
   
10.         dc.Add br(1, i), i
    
11.     Next i
    
12.     For i = 2 To UBound(ar)
    
13.         If Not dr.exists(ar(i, 1)) Then
    
14.             j = j + 1
    
15.             dr.Add ar(i, 1), j
    
16.             cr(j, 1) = ar(i, 1)
    
17.         End If
    
18.         If dc.exists(ar(i, 2)) Then cr(dr(ar(i, 1)), dc(ar(i, 2))) = ar(i, 4)
    
19.     Next i
    
20.     With Sheet2.Cells(3, 1)
    
21.         .Resize(Rows.Count - 2, 21).ClearContents
    
22.         .Resize(j, 21) = cr
    
23.     End With
    
24. End Sub

复制代码

xueyushenl

windimi007 发表于 2013-11-29 09:26
请测试！

谢谢大神，万分感谢。正是我要的结果。