如何获取范围内重复值的列表

我试图录制macros，但它使用复制和粘贴，但我更喜欢代码是dynamic的，因为我的数据范围每周更改。

我有2列， A ＆ D 。 列A是一个数据透视表，所以我想，也许这就是为什么VBA代码向下移动行不行。 （尝试移动数据透视表的错误）。 我希望列D是来自A列的唯一重复列表，并将其压缩以便没有空白。

到目前为止，我可以提取独特的重复和浓缩他们，但结果粘贴它从D1而不是D8 。 所以我需要帮助把价值8行。 现在我不想复制和粘贴数据透视表作为值或试图摆脱它，因为我需要在那里的数据透视表，因为我可以每周刷新它的新列表。

任何build议或build议表示赞赏。

  Sub dp() AR = Cells(Rows.Count, "A").End(xlUp).Row For Each p1 In Range(Cells(8, 1), Cells(AR, 1)) For Each p2 In Range(Cells(8, 1), Cells(AR, 1)) If p1 = p2 And Not p1.Row = p2.Row Then Cells(p1.Row, 4) = Cells(p1.Row, 1) Cells(p2.Row, 4) = Cells(p2.Row, 1) End If Next p2 Next p1 Columns(4).RemoveDuplicates Columns:=Array(1) Dim lastrow As Long Dim i As Long lastrow = Range("D:D").End(xlDown).Row For i = lastrow To 1 Step -1 If IsEmpty(Cells(i, "D").Value2) Then Cells(i, "D").Delete shift:=xlShiftUp End If Next i End Sub 

Answer 1

另一种方法在这里

 Sub dp2() Dim n&, c As Range, rng As Range, Dic As Object Set Dic = CreateObject("Scripting.Dictionary") Dic.comparemode = vbTextCompare Set rng = Range("A8:A" & Cells(Rows.Count, "A").End(xlUp).Row) n = 8 For Each c In rng If Dic.exists(c.Value2) And Dic(c.Value2) = 0 Then Dic(c.Value2) = 1 Cells(n, "D").Value2 = c.Value2 n = n + 1 ElseIf Not Dic.exists(c.Value2) Then Dic.Add c.Value2, 0 End If Next c End Sub 

但如果你喜欢你自己的变体，那么你需要：
1）replace这行代码： Columns(4).RemoveDuplicates Columns:=Array(1)
通过这个： Range("D8:D" & Cells(Rows.Count, "D").End(xlUp).Row).RemoveDuplicates Columns:=1
2）另一个问题是在这行代码： lastrow = Range("D:D").End(xlDown).Row
它会返回第8行而不是你所期望的最后一行，所以你需要用这个行replace它： lastrow = Cells(Rows.Count, "D").End(xlUp).Row

3）也可以代替to 1 step -1 to 8 step -1

所以，最后你的代码可以看起来像这样：

 Sub dp() Dim AR As Long, p1 As Range, p2 As Range, lastrow&, i& AR = Cells(Rows.Count, "A").End(xlUp).Row For Each p1 In Range(Cells(8, 1), Cells(AR, 1)) For Each p2 In Range(Cells(8, 1), Cells(AR, 1)) If p1 = p2 And Not p1.Row = p2.Row Then Cells(p1.Row, 4) = Cells(p1.Row, 1) Cells(p2.Row, 4) = Cells(p2.Row, 1) End If Next p2, p1 Range("D8:D" & Cells(Rows.Count, "D").End(xlUp).Row).RemoveDuplicates Columns:=1 lastrow = Cells(Rows.Count, "D").End(xlUp).Row For i = lastrow To 8 Step -1 If IsEmpty(Cells(i, "D").Value2) Then Cells(i, "D").Delete shift:=xlShiftUp End If Next i End Sub 

Answer 2

这是一个不同的方法

 Sub dp() Dim AR As Long, p1 As Range, n As Long AR = Cells(Rows.Count, "A").End(xlUp).Row n = 8 With Range(Cells(8, 1), Cells(AR, 1)) For Each p1 In .Cells If WorksheetFunction.CountIf(.Cells, p1) > 1 Then If WorksheetFunction.CountIf(Columns(4), p1) = 0 Then Cells(n, "D") = p1 n = n + 1 End If End If Next p1 End With End Sub 

Answer 3

这是另一种方法：

 Option Explicit Sub main() Dim vals As Variant, val As Variant Dim strng As String With Range(Cells(8, 1), Cells(Rows.count, 1).End(xlUp)) vals = Application.Transpose(.Value) strng = "|" & Join(vals, "|") & "|" With .Offset(, 3) .Value = Application.Transpose(vals) .RemoveDuplicates Columns:=1, Header:=xlNo For Each val In .SpecialCells(xlCellTypeConstants) strng = Replace(strng, val, "", , 1) Next val vals = Split(WorksheetFunction.Trim(Replace(strng, "|", " ")), " ") With .Resize(UBound(vals) + 1) .Value = Application.Transpose(vals) .RemoveDuplicates Columns:=1, Header:=xlNo End With End With End With End Sub 

Answer 4

这里有三种不同的技术：

1. ArraysList
2. ADODB.Recordset
3. 数组和CountIf

---

ArraysList

 Sub ListDuplicates() Dim v, listValues, listDups Set listValues = CreateObject("System.Collections.ArrayList") Set listDups = CreateObject("System.Collections.ArrayList") For Each v In Range("A8", Cells(Rows.Count, "A").End(xlUp)).Value If listValues.Contains(v) And Not listDups.Contains(v) Then listDups.Add v listValues.Add v Next Range("D8").Resize(listDups.Count).Value = Application.Transpose(listDups.ToArray) End Sub 

ADODB.Recordset

 Sub QueryDuplicates() Dim rs As Object, s As String Set rs = CreateObject("ADODB.Recordset") s = ActiveSheet.Name & "$" & Range("A7", Cells(Rows.Count, "A").End(xlUp)).Address(False, False) rs.Open "SELECT [Pivot Table] FROM [" & s & "] GROUP BY [Pivot Table] HAVING COUNT([Pivot Table]) > 1", _ "Provider=MSDASQL;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName If Not rs.EOF Then Range("D8").CopyFromRecordset rs rs.Close Set rs = Nothing End Sub 

Array和CountIf（类似于SJR答案，但使用数组来收集数据）

 Sub ListDuplicatesArray() Dim v, vDups Dim x As Long, y As Long ReDim vDups(x) With Range("A8", Cells(Rows.Count, "A").End(xlUp)) For Each v In .Value If WorksheetFunction.CountIf(.Cells, v) > 1 Then For y = 0 To UBound(vDups) If vDups(y) = v Then Exit For Next If y = UBound(vDups) + 1 Then ReDim Preserve vDups(x) vDups(x) = v x = x + 1 End If End If Next End With Range("D8").Resize(UBound(vDups) + 1).Value = Application.Transpose(vDups) End Sub