Excel VBA - remove duplicate data from a row

Question

Hi

I have a sheet of data I would like some VBA code to go through each row and where date from column d onwards has duplicate cell values it deletes that cell and shifts everything left.

How may I do this please?

Thanks for the help.

Answer 1

Thank you very much. That works.

Answer 2

Just FYI it should loop through as long as column A has data if that makes it more efficient.

Before:

After:

Option Explicit

Sub Test()

  Dim A As Range, Where As Range

  Dim Data

  For Each A In Range("A1", Range("A" & Rows.Count).End(xlUp))

    Set Where = Intersect(A.EntireRow, Range("D:F"))

    Data = UniqueItems(Where, vbTextCompare)

    Where.ClearContents

    Where(1).Resize(, UBound(Data) + 1).Value = Data

  Next

End Sub

Private Function UniqueItems(ByVal r As Range, _

    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare, _

    Optional ByRef Count) As Variant

  'Return an array with all unique values in R

  '  and the number of occurrences in Count

  Dim Area As Range, Data

  Dim i As Long, j As Long

  Dim Dict As Object 'Scripting.Dictionary

  Set r = Intersect(r.Parent.UsedRange, r)

  If r Is Nothing Then

    UniqueItems = Array()

    Exit Function

  End If

  Set Dict = CreateObject("Scripting.Dictionary")

  Dict.CompareMode = Compare

  For Each Area In r.Areas

    Data = Area

    If IsArray(Data) Then

      For i = 1 To UBound(Data)

        For j = 1 To UBound(Data, 2)

          If Not Dict.Exists(Data(i, j)) Then

            Dict.Add Data(i, j), 1

          Else

            Dict(Data(i, j)) = Dict(Data(i, j)) + 1

          End If

        Next

      Next

    Else

      If Not Dict.Exists(Data) Then

        Dict.Add Data, 1

      Else

        Dict(Data) = Dict(Data) + 1

      End If

    End If

  Next

  UniqueItems = Dict.Keys

  Count = Dict.Items

End Function

Answer 3

Sub TestMacro()

Dim C As Range

Dim lngR As Long

Dim lngC As Long

Dim lngFR As Long

Dim lngLR As Long

Dim lngLC As Long

Dim lngFC As Long

With ActiveSheet

Set C = Intersect(.UsedRange, .Range(.Range("E:E"), .Cells(1, .Columns.Count).EntireColumn))

lngLR = C.Cells(C.Cells.Count).Row

lngFR = C.Cells(1, 1).Row

lngLC = C.Cells(C.Cells.Count).Column

lngFC = C.Cells(1, 1).Column

For lngR = lngLR To lngFR Step -1

For lngC = lngLC To lngFC Step -1

If .Cells(lngR, lngC).Value = .Cells(lngR, "D").Value Then .Cells(lngR, lngC).Delete xlToLeft

Next lngC

Next lngR

End With

End Sub

Answer 4

Hi

So I have data similar to this:

	A	B	C	D	E	F	G
1				ABC	DEF	ABC
2				DEF	DEF	ABC

It should loop through the rows 1 & 2 and onwards if needed and check where columns have duplicates so for Row 1 D & F are duplicates, for Row 2 D & E are. It should delete the duplicate and shift the data left so would look like this:

	A	B	C	D	E	F	G
1				ABC	DEF
2				DEF	ABC

Hope that is clearer?

Just FYI it should loop through as long as column A has data if that makes it more efficient.

Answer 5

Hi jamphi24

Could you tell us what do you mean with*"* it deletes that cell and shifts everything left."?

Here a sample picture with 4 duplicate dates

Please show us the results from the sample above.