如何获取

Question

我尝试录制宏但是它使用复制和粘贴，但我更喜欢这些代码是动态的，因为我的数据范围每周都在变化。

我有两列A＆amp; D。列A是一个数据透视表，所以我想，也许这就是为什么VBA代码向下移动行不能正常工作的原因。 （尝试移动数据透视表时出错）。 我希望列D是来自列A的唯一重复列表，并将其压缩，以便没有间隙。

到目前为止，我可以提取唯一的重复项并压缩它们，但结果是从D1而不是D8 粘贴的。所以我需要帮助来降低8行的值。现在我不想将数据透视表复制并粘贴为值或试图摆脱它，因为我需要数据透视表，因为我可以每周刷新它以获取新列表。

感谢任何建议或建议。

    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 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 2

以下是三种不同的技术：

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

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

另一种方法

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）替换这行代码：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行而不是您预期的最后一行，因此您需要将其替换为：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