[已解决]通过数据 建立一个表格 求助VBA

cocoYan199015

我上传了一个列子 数据在sheet1里面, 这只是数据的一小部分  我希望在sheet2上根据sheet1的数据建立一个表格如我加入的一个截屏.

表格中的 1 2 3 4 5 6 分别对应 车 健康 房子 的前六个 对应的B列中的变量

求各位高手帮忙看看 感激不尽

最佳答案

月排行榜 / 总排行榜

冥王

2015-6-2 12:46

1. Sub demo()
   
2.     Dim d As New Dictionary, dic As New Dictionary  '引用microsoft scripting runtime
   
3.     Dim i%, j%, k%, n%, sKey
   
4.     Dim arr, brr(1 To 50000, 1 To 7)
   
5.     With ThisWorkbook
   
6.         arr = .Sheets(1).Range("A1:B" & .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
   
7.         For i = LBound(arr, 1) To UBound(arr, 1)
   
8.             If Not d.Exists(arr(i, 1)) Then
   
9.                 j = 1
   
10.             Else
    
11.                 j = j + 1
    
12.             End If
    
13.             d(arr(i, 1)) = ""
    
14.             dic(arr(i, 1) & j) = arr(i, 2)
    
15.         Next
    
16.         sKey = d.Keys
    
17.         For k = 1 To d.Count
    
18.             brr(k, 1) = sKey(k - 1)
    
19.             For n = 1 To 6
    
20.                 brr(k, n + 1) = dic(sKey(k - 1) & n)
    
21.             Next
    
22.         Next
    
23.         .Sheets(2).Range("A2").Resize(d.Count, 7) = brr
    
24.     End With
    
25. End Sub

复制代码

跳转到最佳答案楼层

冥王

1. Sub demo()
   
2.     Dim d As New Dictionary, dic As New Dictionary  '引用microsoft scripting runtime
   
3.     Dim i%, j%, k%, n%, sKey
   
4.     Dim arr, brr(1 To 50000, 1 To 7)
   
5.     With ThisWorkbook
   
6.         arr = .Sheets(1).Range("A1:B" & .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
   
7.         For i = LBound(arr, 1) To UBound(arr, 1)
   
8.             If Not d.Exists(arr(i, 1)) Then
   
9.                 j = 1
   
10.             Else
    
11.                 j = j + 1
    
12.             End If
    
13.             d(arr(i, 1)) = ""
    
14.             dic(arr(i, 1) & j) = arr(i, 2)
    
15.         Next
    
16.         sKey = d.Keys
    
17.         For k = 1 To d.Count
    
18.             brr(k, 1) = sKey(k - 1)
    
19.             For n = 1 To 6
    
20.                 brr(k, n + 1) = dic(sKey(k - 1) & n)
    
21.             Next
    
22.         Next
    
23.         .Sheets(2).Range("A2").Resize(d.Count, 7) = brr
    
24.     End With
    
25. End Sub

复制代码

cocoYan199015

冥王 发表于 2015-6-2 12:46

十分感谢！！！！