[已解决]数据处理问题

fanyuxiaohao

数据量很大，无法手工完成。关键是要把左侧一列的重复的项目在右侧不同列显示。（右侧数据是完全不重复的，左侧数据有重复）

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-8 12:08

最终数据会产生在I列及之后，代码如下：

1. Sub 转化()
   
2.     Dim dc As Object, arr, brr, n&, i&, j&, crr, x&, drr(), xrr
   
3.     Set dc = CreateObject("Scripting.Dictionary")
   
4.     n = Sheet1.Cells(Sheet1.Rows.Count, 3).End(xlUp).Row
   
5.     arr = Sheet1.Range("C1:C" & n)
   
6.     brr = Sheet1.Range("e1:e" & n)
   
7.     For i = 1 To n - 1
   
8.         If Not dc.exists(arr(i, 1)) Then
   
9.             dc.Add arr(i, 1), ""
   
10.             y = y + 1
    
11.             ReDim Preserve drr(1 To y)
    
12.             Set drr(y) = CreateObject("Scripting.Dictionary")
    
13.             
    
14.         End If
    
15.         If Not drr(y).exists(brr(i, 1)) Then
    
16.             drr(y).Add brr(i, 1), ""
    
17.         End If
    
18.     Next
    
19.     crr = dc.Keys
    
20.     For i = 1 To dc.Count
    
21.         xrr = drr(i).Keys
    
22.         Sheet1.Cells(i, 9) = crr(i - 1)
    
23.         Sheet1.Cells(i, 10).Resize(1, drr(i).Count) = xrr
    
24.     Next
    
25. End Sub

复制代码

跳转到最佳答案楼层

心正意诚身修

兩個公式倒是可以實現。可是如果有個幾百上千行的數據的話。。電腦直接就能卡死。

心正意诚身修

你把你的文件打包壓縮。然後添加附件。。
我給你轉到VBA版塊去。數據量大，函數不是好選擇。

fanyuxiaohao

心正意诚身修 发表于 2016-6-8 10:35
你把你的文件打包壓縮。然後添加附件。。
我給你轉到VBA版塊去。數據量大，函數不是好選擇。

我已经上传附件了，不过只有部分数据，请见谅，公司有相关制度。{:4312:}

心正意诚身修

fanyuxiaohao 发表于 2016-6-8 10:40
我已经上传附件了，不过只有部分数据，请见谅，公司有相关制度。

函數解法。
區域自己修改。
數組公式。
數據量大電腦會卡。

老司机带带我

最终数据会产生在I列及之后，代码如下：

1. Sub 转化()
   
2.     Dim dc As Object, arr, brr, n&, i&, j&, crr, x&, drr(), xrr
   
3.     Set dc = CreateObject("Scripting.Dictionary")
   
4.     n = Sheet1.Cells(Sheet1.Rows.Count, 3).End(xlUp).Row
   
5.     arr = Sheet1.Range("C1:C" & n)
   
6.     brr = Sheet1.Range("e1:e" & n)
   
7.     For i = 1 To n - 1
   
8.         If Not dc.exists(arr(i, 1)) Then
   
9.             dc.Add arr(i, 1), ""
   
10.             y = y + 1
    
11.             ReDim Preserve drr(1 To y)
    
12.             Set drr(y) = CreateObject("Scripting.Dictionary")
    
13.             
    
14.         End If
    
15.         If Not drr(y).exists(brr(i, 1)) Then
    
16.             drr(y).Add brr(i, 1), ""
    
17.         End If
    
18.     Next
    
19.     crr = dc.Keys
    
20.     For i = 1 To dc.Count
    
21.         xrr = drr(i).Keys
    
22.         Sheet1.Cells(i, 9) = crr(i - 1)
    
23.         Sheet1.Cells(i, 10).Resize(1, drr(i).Count) = xrr
    
24.     Next
    
25. End Sub

复制代码

fanyuxiaohao

老司机带带我 发表于 2016-6-8 12:08
最终数据会产生在I列及之后，代码如下：

{:2812:}有时间要学下VBA