[已解决]数组的字典运用具有高效的排重的功能,但如何才能按附件中的进行排重呢?

fssunnymen

数组的字典运用具有高效的排重的功能,但如何才能按附件中的进行排重呢?

SDH3bZiX.rar (9.59 KB, 下载次数: 11)

2008-12-10 15:41 上传

点击文件名下载附件
数组的字典运用具有高效的排重的功能,但如何才能按附件中的进行排重呢?

最佳答案

月排行榜 / 总排行榜

baogc1983

2008-12-10 22:56

Sub Tt()
Dim r As Integer
r = Sheets("sheet1").Range("A65536").End(xlUp).Row
Dim a
a = Range("A2:C" & r)
Dim d As New Dictionary
For i = 1 To r - 1
牋?d(a(i, 1)) = ""
牋?d(a(i, 1) & a(i, 2)) = ""
牋?d(a(i, 1) & a(i, 2) & a(i, 3)) = ""
Next
With Sheets("Sheet1")
牋?.Range("E:G").Clear
牋?.Range("E1:G1") = .Range("A1:C1").Value
牋?.Range("E2").Resize(d.Count) = Application.Transpose(d.Keys)
牋?.Range("E2:G" & d.Count + 1).Sort Key1:=Range("E2")
牋?.Range("E2:E" & d.Count + 1).TextToColumns Destination:=.Range("E2"), _
牋牋牋?DataType:=xlFixedWidth, _
牋牋牋?FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(12, 1))
End With
Set d = Nothing
End Sub

跳转到最佳答案楼层

青城山苦丁茶

试试：

Sub test()
Dim d1 As New Dictionary, d2 As New Dictionary
Dim str1 As String, i1 As Integer, i2 As Integer, arr1(), arr2()
arr1 = Range("a2", [c2].End(4)).Value
For i1 = 1 To UBound(arr1)
  str1 = arr1(i1, 1) & "|" & arr1(i1, 2) & "|" & arr1(i1, 3)
  If Not d1.Exists(str1) Then
     d1(str1) = ""
     If d2.Exists(arr1(i1, 1)) Then
       arr2 = d2(arr1(i1, 1))
       i2 = UBound(arr2, 2) + 1
       ReDim Preserve arr2(1 To 3, 1 To i2)
    Else
       ReDim arr2(1 To 3, 1 To 3)
       arr2(1, 1) = arr1(i1, 1)
       arr2(1, 2) = arr1(i1, 1)
       arr2(2, 2) = arr1(i1, 2)
       i2 = 3
     End If
     arr2(1, i2) = arr1(i1, 1)
     arr2(2, i2) = arr1(i1, 2)
     arr2(3, i2) = arr1(i1, 3)
     d2(arr1(i1, 1)) = arr2
     Erase arr2
  End If
Next
i2 = 2
For i1 = 0 To d2.Count - 1
  arr2 = Application.Transpose(d2.Items(i1))
  Cells(i2, 8).Resize(UBound(arr2), 3) = arr2
  i2 = i2 + UBound(arr2)
  Erase arr2
Next
End Sub

baogc1983

Sub Tt()
Dim r As Integer
r = Sheets("sheet1").Range("A65536").End(xlUp).Row
Dim a
a = Range("A2:C" & r)
Dim d As New Dictionary
For i = 1 To r - 1
牋?d(a(i, 1)) = ""
牋?d(a(i, 1) & a(i, 2)) = ""
牋?d(a(i, 1) & a(i, 2) & a(i, 3)) = ""
Next
With Sheets("Sheet1")
牋?.Range("E:G").Clear
牋?.Range("E1:G1") = .Range("A1:C1").Value
牋?.Range("E2").Resize(d.Count) = Application.Transpose(d.Keys)
牋?.Range("E2:G" & d.Count + 1).Sort Key1:=Range("E2")
牋?.Range("E2:E" & d.Count + 1).TextToColumns Destination:=.Range("E2"), _
牋牋牋?DataType:=xlFixedWidth, _
牋牋牋?FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(12, 1))
End With
Set d = Nothing
End Sub