|
看一下楼主给出的数据,A列与B列是一样的,不知道实际的数据是否是这样,这与楼主给的示例是不同的的,以下代码适用实际数据,分组后是有些较大的组,水平放置是放不下的,按列放置由于分组数很多,有700多组,也是不行的,一个工作表是不好存放结果的。
- Option Explicit
- Function findRowID_first(rng As Range, key As Variant, Optional first As Long = 1, Optional last As Long = -1) As Long
- Dim low&, hight&, cur&
- low = first
- hight = last
- If last = -1 Then hight = rng.Rows.Count + first - 1
- cur = low
- Do
- If rng.Cells(cur, 1) < key Then
- low = cur
- Else
- hight = cur
- End If
-
- cur = low + (hight - low) \ 2
-
- Loop While hight - low > 1
- findRowID_first = IIf(rng.Cells(hight, 1) = key, hight, -1)
-
- End Function
- Sub getData()
- Dim dt As Object
- Dim ds As Object
-
- Dim last&, r&, c&, i&
- Dim str$
- Dim ar() As Variant
- Dim u&, v&
-
- Set dt = CreateObject("Scripting.Dictionary")
- Set ds = CreateObject("Scripting.Dictionary")
- Application.ScreenUpdating = False
- Sheets("s").Cells.ClearContents
- Sheets("s1").Cells.ClearContents
- Sheets("temp").Cells.ClearContents
- Sheets("s").Range("a1") = "number"
-
-
- With Sheets("temp")
- Sheets("Sheet2").Range("A1").CurrentRegion.Copy .Range("A1")
-
- .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("B2")
- r = 2
- c = 2
- str = .Cells(2, 1)
- Do While Len(str) <> 0
-
- dt.RemoveAll
- ds.RemoveAll
- dt(str) = ""
- Do While dt.Count <> 0
-
-
- str = dt.keys()(0)
-
- dt.Remove str
- ds(str) = ""
- last = .Range("a65536").End(xlUp).Row
- i = findRowID_first(.Range("a1:a" & last), str, 2, last)
-
- If i <> -1 Then
- Do While 1
- If .Cells(i, 1) <> str Then Exit Do
- If Not ds.Exists(.Cells(i, 2).Value) Then dt(.Cells(i, 2).Value) = ""
- .Rows(i).Delete
-
- Loop
-
- End If
- Loop
-
- Sheets("s").Range("a" & r) = ds.Count
-
- If ds.Count < 30 Then
- Sheets("s").Range("c" & r).Resize(1, ds.Count) = ds.keys
- Else
- Sheets("s1").Cells(1, c) = ds.Count
- Sheets("s1").Cells(2, c).Resize(ds.Count, 1) = Application.Transpose(ds.keys)
- c = c + 1
-
- End If
- r = r + 1
- str = .Cells(2, 1)
- Loop
-
- Sheets("s").Range("b1") = r - 2
-
- End With
-
- Application.ScreenUpdating = True
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|