I tried recording the macros but it's using copying and pasting, but I prefer the codes to be dynamic as the range of my data changes weekly.
I have 2 columns, A
& D
. Column A
is a pivot table, so I think, maybe that's why VBA
codes for moving down rows don't work. (error for trying to move pivot table). I want Column D
to be a list of unique duplicates that are from column A
and condense it so no gaps.
So far I can extract the unique duplicates and condense them but the results are pasted it from D1 instead of D8. So I need help to bring down the values 8 rows. Now I don't want to copy and paste the pivot table as values or trying to get rid of it since I need the pivot table there as I can just refresh it every week for new list.
Any suggestion or advice is appreciated.
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
Here is a different approach
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
here's another approach:
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
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With