[已解决]希望解决以下问题，谢谢！看附件

A1090A

20111228问题.rar (2.39 KB, 下载次数: 19)

2011-12-28 21:56 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-12-29 10:26

1. Sub justtest()
   
2.     Dim D As New Dictionary, Arr, i&, k As Byte, Mc As Byte
   
3.     Dim Mr&, ArrT() As String, j As Byte
   
4.     Application.ScreenUpdating = False
   
5.     With Worksheets("基础表")
   
6.         Mc = .Cells(1, .Columns.Count).End(1).Column
   
7.         Mr = .Cells(.Rows.Count, 1).End(3).Row
   
8.         Arr = .Cells(1, 1).Resize(Mr, Mc).Value
   
9.     End With
   
10.     ReDim ArrT(1 To Mr - 1, 1 To Mc)
    
11.     For i = 2 To Mr
    
12.         ArrT(i - 1, 1) = Arr(i, 1)
    
13.         D.RemoveAll: k = 1
    
14.         For j = 2 To Mc
    
15.             If Not D.Exists(Arr(i, j)) Then
    
16.                 k = k + 1: ArrT(i - 1, k) = Arr(i, j)
    
17.                 D.Add Arr(i, j), 0
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     With Worksheets("结果表")
    
22.         .Cells.Clear
    
23.         .Range("A1").Resize(1, Mc) = Application.Index(Arr, 1, 0)
    
24.         .Range("A2").Resize(Mr - 1, Mc) = ArrT
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     Set D = Nothing
    
28. End Sub
    

复制代码

20111228问题.rar (340.39 KB, 下载次数: 19)

2011-12-29 10:26 上传

点击文件名下载附件
试试是附件效果不？

跳转到最佳答案楼层

liuguansky

传个大点的数据源吧。

9lee

1. Sub test()
   
2.     Dim d As New Dictionary
   
3.     Dim arr, brr(), i, j, k, d_count
   
4.     Application.ScreenUpdating = False
   
5.     arr = Sheets("基础表").Range("a1").CurrentRegion
   
6.     ReDim brr(1 To UBound(arr, 1), 1 To 1)
   
7.     For i = 2 To UBound(arr, 1)
   
8.         For j = 1 To UBound(arr, 2)
   
9.             d(arr(i, j)) = ""
   
10.         Next j
    
11.         d_count = d.Count
    
12.         If d_count > 1 Then
    
13.             dk = d.Keys
    
14.             If d_count > UBound(brr, 2) Then ReDim Preserve brr(1 To UBound(arr, 1), 1 To d_count)
    
15.             Set d = Nothing
    
16.             For k = 1 To d_count
    
17.                 brr(i, k) = dk(k - 1)
    
18.             Next k
    
19.         End If
    
20.     Next i
    
21.     brr(1, 1) = arr(1, 1)
    
22.     For i = 2 To UBound(brr, 2)
    
23.         brr(1, i) = "车型" & i
    
24.     Next i
    
25.     With Sheets("结果表")
    
26.         .Cells.ClearContents
    
27.         .[a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

liuguansky

1. Sub justtest()
   
2.     Dim D As New Dictionary, Arr, i&, k As Byte, Mc As Byte
   
3.     Dim Mr&, ArrT() As String, j As Byte
   
4.     Application.ScreenUpdating = False
   
5.     With Worksheets("基础表")
   
6.         Mc = .Cells(1, .Columns.Count).End(1).Column
   
7.         Mr = .Cells(.Rows.Count, 1).End(3).Row
   
8.         Arr = .Cells(1, 1).Resize(Mr, Mc).Value
   
9.     End With
   
10.     ReDim ArrT(1 To Mr - 1, 1 To Mc)
    
11.     For i = 2 To Mr
    
12.         ArrT(i - 1, 1) = Arr(i, 1)
    
13.         D.RemoveAll: k = 1
    
14.         For j = 2 To Mc
    
15.             If Not D.Exists(Arr(i, j)) Then
    
16.                 k = k + 1: ArrT(i - 1, k) = Arr(i, j)
    
17.                 D.Add Arr(i, j), 0
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     With Worksheets("结果表")
    
22.         .Cells.Clear
    
23.         .Range("A1").Resize(1, Mc) = Application.Index(Arr, 1, 0)
    
24.         .Range("A2").Resize(Mr - 1, Mc) = ArrT
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     Set D = Nothing
    
28. End Sub
    

复制代码

20111228问题.rar (340.39 KB, 下载次数: 19)

2011-12-29 10:26 上传

点击文件名下载附件
试试是附件效果不？

A1090A

感谢大家回复，是这样效果，感谢2-4楼