类别转置问题

banditson

请问如何将附表中A\B两列内容变成D---I列的格式，最终A\B两列原有数据不要，生成内容放到A---F列，谢谢！！！！
TEST.rar (10.29 KB, 下载次数: 7)

2018-8-21 17:00 上传

点击文件名下载附件

苏小亓

直接透视就可以啊。

microyip

1. Sub ChangData()
   
2.     Dim dicData As Object
   
3.     Dim vData As Variant, nRow As Double
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     Set dicData = CreateObject("Scripting.Dictionary")
   
7.     vData = [A1].CurrentRegion.Value
   
8.     For nRow = 1 To UBound(vData)
   
9.         If Not dicData.Exists(vData(nRow, 1)) Then Set dicData(vData(nRow, 1)) = CreateObject("Scripting.Dictionary")
   
10.         dicData(vData(nRow, 1))(vData(nRow, 2)) = 0
    
11.     Next
    
12.     [A1].Resize(, dicData.Count).EntireColumn.ClearContents
    
13.     With [A1]
    
14.         nRow = 0
    
15.         For Each vData In dicData.Keys
    
16.             .Offset(, nRow) = vData
    
17.             .Offset(1, nRow).Resize(dicData(vData).Count) = Application.WorksheetFunction.Transpose(dicData(vData).Keys())
    
18.             nRow = nRow + 1
    
19.         Next
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

microyip

附上附件以供参考

banditson

microyip 发表于 2018-8-21 17:48

循环字典？这么强大！感谢指点，这个要慢慢消化。谢谢谢谢！！！！！！

banditson

苏小亓 发表于 2018-8-21 17:03
直接透视就可以啊。

自动生成不用每次去手工处理，因为每天都是重复工作。

chaohuahch

用一个字典解决问题的方案。

1. Sub fyExcelVBA()
   
2. Dim arr, brr, i%, j%
   
3. Dim dic, dic1
   
4. Application.DisplayAlerts = False
   
5. arr = Range("A1").CurrentRegion
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. For i = 1 To UBound(arr)
   
8.      If Not dic.exists(arr(i, 1)) Then
   
9.         dic(arr(i, 1)) = arr(i, 2)
   
10.       Else
    
11.         dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
    
12.       End If
    
13. Next i
    
14. Cells.ClearContents
    
15. Range("a1").Resize(1, dic.Count) = dic.keys
    
16. For i = 0 To dic.Count - 1
    
17.     item1 = VBA.Split(dic.items()(i), "|")
    
18.     Cells(2, 1 + i).Resize(UBound(item1) + 1, 1) = WorksheetFunction.Transpose(item1)
    
19. Next i
    
20. Set dic = Nothing
    
21. 
    
22. End Sub
    

复制代码