[已解决]查找列相同项所对应其他列的数据并转成行对应排列问题

请教高人，要实现下面的功能，用VBA如何写代码？如何执行？
                                                                                       
序号        名称        价格        日期        供方                想在表二实现的功能如下                                       
1        小明        10        2014/2/12        大唐                                                       
                21        2014/5/25        大明                序号        名称                               
                22        2014/8/7        大清                1        小明        供方        大唐        大明        大清
2        小红        2        2014/3/5        元                                价格        10        21        22
                34        2014/8/9        秦                                日期        2014/2/12        2014/5/25        2014/8/7
                21        2014/6/14        楚                2        小红                               
3        小青        45        2014/3/21        赵                                                       
                33        2014/9/17        晋                3        小青                               
4        小灯        22        2014/5/15        楚                                                       
                                                                                       
        如此的原始数据有上千行                                                                               
                                                因为表的数据内容很多，不想用公式实现，希望高人能够指导VBA来实现                                       
                                                                                       
                                                                                       

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-14 19:51

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. ReDim brr(1 To 20000, 1 To 100)
   
7. For i = 2 To UBound(arr)
   
8.     If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
9.     If Not d2.exists(arr(i, 1)) Then d2(arr(i, 1)) = 4 Else d2(arr(i, 1)) = d2(arr(i, 1)) + 1
   
10.     l = d2(arr(i, 1)): If s2 < l Then s2 = l
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.         n = n + 1
    
13.         s = (n - 1) * 3 + 1
    
14.         d(arr(i, 1)) = s
    
15.         brr(s, 1) = arr(i, 1)
    
16.         brr(s, 2) = arr(i, 2)
    
17.         brr(s, 3) = arr(1, 5)
    
18.         brr(s + 1, 3) = arr(1, 3)
    
19.         brr(s + 2, 3) = arr(1, 4)
    
20.         brr(s, l) = arr(i, 5)
    
21.         brr(s + 1, l) = arr(i, 3)
    
22.         brr(s + 2, l) = arr(i, 4)
    
23.     Else
    
24.         h = d(arr(i, 1))
    
25.         brr(h, l) = arr(i, 5)
    
26.         brr(h + 1, l) = arr(i, 3)
    
27.         brr(h + 2, l) = arr(i, 4)
    
28.     End If
    
29. Next
    
30. Sheet2.Range("a2").Resize(n * 3, s2) = brr
    
31. End Sub

复制代码

跳转到最佳答案楼层

序号	名称	价格	日期	供方		想在表二实现的功能如下
1	小明	10	2014/2/12	大唐
		21	2014/5/25	大明		序号	名称
		22	2014/8/7	大清		1	小明	供方	大唐	大明	大清
2	小红	2	2014/3/5	元				价格	10	21	22
		34	2014/8/9	秦				日期	2014/2/12	2014/5/25	2014/8/7
		21	2014/6/14	楚		2	小红
3	小青	45	2014/3/21	赵
		33	2014/9/17	晋		3	小青
4	小灯	22	2014/5/15	楚
	如此的原始数据有上千行
						因为表的数据内容很多，不想用公式实现，希望高人能够指导VBA来实现

怎么没有人帮忙呢？求兰版指点啊！几千条的数据等待处理。谢谢了！谢谢了！

26759761@qq.com

传附件

我也想传附件，但是今天上班，公司电脑全部加密，解密权限全公司只有一人，今天还请假，文件传上来也是加密文件！不好意思！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. ReDim brr(1 To 20000, 1 To 100)
   
7. For i = 2 To UBound(arr)
   
8.     If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
9.     If Not d2.exists(arr(i, 1)) Then d2(arr(i, 1)) = 4 Else d2(arr(i, 1)) = d2(arr(i, 1)) + 1
   
10.     l = d2(arr(i, 1)): If s2 < l Then s2 = l
    
11.     If Not d.exists(arr(i, 1)) Then
    
12.         n = n + 1
    
13.         s = (n - 1) * 3 + 1
    
14.         d(arr(i, 1)) = s
    
15.         brr(s, 1) = arr(i, 1)
    
16.         brr(s, 2) = arr(i, 2)
    
17.         brr(s, 3) = arr(1, 5)
    
18.         brr(s + 1, 3) = arr(1, 3)
    
19.         brr(s + 2, 3) = arr(1, 4)
    
20.         brr(s, l) = arr(i, 5)
    
21.         brr(s + 1, l) = arr(i, 3)
    
22.         brr(s + 2, l) = arr(i, 4)
    
23.     Else
    
24.         h = d(arr(i, 1))
    
25.         brr(h, l) = arr(i, 5)
    
26.         brr(h + 1, l) = arr(i, 3)
    
27.         brr(h + 2, l) = arr(i, 4)
    
28.     End If
    
29. Next
    
30. Sheet2.Range("a2").Resize(n * 3, s2) = brr
    
31. End Sub

复制代码

dsmch

………………

非常感谢Dsmch,太谢谢了！昨天在网上了买了兰版的80级VBA视频教程，一口气看了8级，非常不错，看完茅塞顿开啊！谢谢！

再请问老师，如果是下面这种情况，要实现之前的结果，应该调整那部分代码？
序号        名称        价格        日期        供方
1        小明        10        2014/2/12        大唐
2        小明        21        2014/5/25        大明
3        小明        22        2014/8/7        大清
4        小红        2        2014/3/5        元
5        小红        34        2014/8/9        秦
6        小红        21        2014/6/14        楚
7        小青        45        2014/3/21        赵
8        小青        33        2014/9/17        晋
9        小灯        22        2014/5/15        楚

dsmch 发表于 2015-2-14 19:51

再请问老师，如果是下面这种情况，要实现之前的结果，应该调整那部分代码？
序号        名称        价格        日期        供方
1        小明        10        2014/2/12        大唐
2        小明        21        2014/5/25        大明
3        小明        22        2014/8/7        大清
4        小红        2        2014/3/5        元
5        小红        34        2014/8/9        秦
6        小红        21        2014/6/14        楚
7        小青        45        2014/3/21        赵
8        小青        33        2014/9/17        晋
9        小灯        22        2014/5/15        楚