| 楼主 breezy |
Q:如何在一列中挑选重复数据? A:方法很多，有ADO法，循环对比数据，数据透视图等，下列提供字典法来取重复数，速度最快。
 字典法取重复数.rar |
| 2楼 刘志文 |
向breezy版主学习 |
| 3楼 水星钓鱼 |
感谢分享。 |
| 4楼 zyg365 |
一、不区分大小写的： Sub 求单列重复与不重复值() Dim d As Object, i&, k&, m&, ar, arr(), arrr() Set d = CreateObject("scripting.dictionary") With Sheets("sheet1") .[c:e].ClearContents .[c1:e1] = Array("不重复值", "重复值", "重复次数") ar = .Range("a2", .[a65536].End(3)) ReDim arr(1 To UBound(ar), 1 To 2) For i = 1 To UBound(ar) If Not d.exists(ar(i, 1)) Then k = k + 1 d(ar(i, 1)) = k arr(k, 1) = ar(i, 1) End If arr(d(ar(i, 1)), 2) = arr(d(ar(i, 1)), 2) + 1 Next ReDim arrr(1 To k, 1 To 3) For i = 1 To k If arr(i, 2) = 1 Then j = j + 1 arrr(j, 1) = arr(i, 1) ElseIf arr(i, 2) > 1 Then m = m + 1 arrr(m, 2) = arr(i, 1) arrr(m, 3) = arr(i, 2) End If Next .[c2].Resize(k, 3) = arrr End With End Sub Sub Ex() Dim Rng As Range, E As Range, Ar(), xP As Integer, xA As Integer, xB As Integer, xS As String With Sheets("Sheet1") Set Rng = .Range(.[A2], .[A2].End(xlDown)) ReDim Ar(1 To 3, Rng.Rows.Count) Ar(1, 0) = "不重復" Ar(2, 0) = "重復" Ar(3, 0) = "次數" xA = 1 xB = 1 For Each E In Rng xP = Application.CountIf(Rng, E) If xP = 1 Then Ar(1, xA) = E xA = xA + 1 Else If InStr(xS, "," & E) = 0 Then xS = IIf(xS <> "", xS & "," & E, "," & E) Ar(2, xB) = E Ar(3, xB) = xP xB = xB + 1 End If End If Next xP = IIf(xA > xB, xA, xB) ReDim Preserve Ar(1 To 3, xP) With .[C1] .CurrentRegion.Clear .Resize(xP, UBound(Ar)).Value = Application.Transpose(Ar) .CurrentRegion.Interior.ColorIndex = 6 .CurrentRegion.Borders.LineStyle = 1 End With End With End Sub 不区分大小写的：标记行号 Sub Ex() Dim Rng As Range, E As Range, Ar(), xP As Integer, xA As Integer, xB As Integer, xS As String Dim xf As Variant With Sheets("Sheet1") Set Rng = .Range(.[A2], .[A2].End(xlDown)) ReDim Ar(1 To 4, Rng.Rows.Count) Ar(1, 0) = "不重復" Ar(2, 0) = "重復" Ar(3, 0) = "次數" Ar(4, 0) = "所在行" xA = 1 xB = 1 For Each E In Rng xP = Application.CountIf(Rng, E) If xP = 1 Then Ar(1, xA) = E xA = xA + 1 Else If InStr(xS, "," & E) = 0 Then xS = IIf(xS <> "", xS & "," & E, "," & E) Ar(2, xB) = E Ar(3, xB) = xP Ar(4, xB) = E.Row xB = xB + 1 Else xf = Mid(xS, 2) xf = Split(xf, ",") xf = Application.Match(E.Text, xf, 0) Ar(4, xf) = Ar(4, xf) & "," & E.Row End If End If Next xP = IIf(xA > xB, xA, xB) ReDim Preserve Ar(1 To 4, xP) With .[C1] .CurrentRegion.Clear .Resize(xP, UBound(Ar)).Value = Application.Transpose(Ar) .CurrentRegion.Interior.ColorIndex = 6 .CurrentRegion.Borders.LineStyle = 1 .CurrentRegion.HorizontalAlignment = xlCenter End With End With End Sub Sub Ex_Dictionary() Dim d(1 To 2) As Object, Rng As Range, xP As Integer, E As Range, Ar() Set d(1) = CreateObject("scripting.dictionary") Set d(2) = CreateObject("scripting.dictionary") With Sheets("Sheet1") Set Rng = .Range(.[A2], .[A2].End(xlDown)) For Each E In Rng xP = Application.CountIf(Rng, E) If xP = 1 Then d(1)(E.Text) = "" Else If d(2).exists(E.Text) = False Then d(2)(E.Text) = Array(E.Text, xP, E.Row) Else Ar = d(2)(E.Text) Ar(2) = Ar(2) & "," & E.Row d(2)(E.Text) = Ar End If End If Next With .[C1] .CurrentRegion.Clear .Resize(, 4) = Array("不重復", "重復", "次數", "所在行") .Cells(2).Resize(d(1).Count) = Application.Transpose(d(1).keys) .Cells(2, 2).Resize(d(2).Count, 3).Value = Application.Transpose(Application.Transpose(d(2).items)) .CurrentRegion.Interior.ColorIndex = 6 .CurrentRegion.Borders.LineStyle = 1 .CurrentRegion.HorizontalAlignment = xlCenter End With End With End Sub 二、区分大小写的：标记行号 Sub Ex() Dim d(1 To 2) As Object, xKey As Variant, E As Range, Ar() Set d(1) = CreateObject("scripting.dictionary") Set d(2) = CreateObject("scripting.dictionary") With Sheets("Sheet1") For Each E In .Range(.[A2], .[A2].End(xlDown)) If d(1).exists(E.Text) = False Then d(1)(E.Text) = Array(E.Text, 1, E.Row) Else Ar = d(1)(E.Text) Ar(1) = Ar(1) + 1 Ar(2) = Ar(2) & "," & E.Row d(1)(E.Text) = Ar End If Next For Each xKey In d(1).keys If d(1)(xKey)(1) > 1 Then d(2)(xKey) = d(1)(xKey) d(1).Remove xKey End If Next With .[C1] .CurrentRegion.Clear .Resize(, 4) = Array("不重復", "重復", "次數", "所在行") If d(1).Count > 0 Then .Cells(2).Resize(d(1).Count) = Application.Transpose(d(1).keys) If d(2).Count > 0 Then .Cells(2, 2).Resize(d(2).Count, 3).Value = Application.Transpose(Application.Transpose(d(2).items)) .CurrentRegion.Interior.ColorIndex = 6 .CurrentRegion.Borders.LineStyle = 1 .CurrentRegion.HorizontalAlignment = xlCenter End With End With End Sub |
| 5楼 bluexuemei |
学习! |