EXCEL :: Delete columns if each cell&#x27;s values are the same

I believe you mean duplicate rows? you can use Excel built-in wizard to remove the duplicate rows...

go to Data tab, look for Remove Duplicates

ASKER

Thank you for your reply. However, I do know how to use that feature. I am looking for a macro to scan the entire spreadsheet and look for columns that have repeating value (from row b till the end) and remove them.

you can try use this macro:

Sub RemoveDups()
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    ActiveSheet.Range("$A$1:$" & Chr(64 + LastCol) & "$" & lastRow).RemoveDuplicates Columns:=LastCol, Header:=xlYes
End Sub

ASKER

Thank you.. I get an error

on this line

ActiveSheet.Range("$A$1:$" & Chr(64 + LastCol) & "$" & lastRow).RemoveDuplicates Columns:=LastCol, Header:=xlYes

ASKER

Here is a sample file attached...
Sample-Delete-Columns-that-have-sam.xlsm

this works fine with me.
Sample-Delete-Columns-that-have-sam.xlsm

ASKER

Ryan,
Sorry if I wasn't clear... I am looking to delete entire columns like this (Only 2 columns remain as not every cell is the same in that column)...

BEFORE....

AFTER....

ok, understand now. so you can try this:

Sub RemoveDupCols()
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = lastCol To 1 Step -1
        LastRow = Cells(Rows.Count, Chr(64 + i)).End(xlUp).Row
        uniqueCount = CountUnique(ActiveSheet.Range("$" & Chr(64 + i) & "$2:$" & Chr(64 + i) & "$" & LastRow))
        Debug.Print "Column " & Chr(64 + i) & "'s unique values count:" & uniqueCount
        If uniqueCount = 1 Then
            Columns(Chr(64 + i)).Delete Shift:=xlToLeft
        End If
    Next
End Sub

Public Function CountUnique(rng As Range) As Long
    Dim dict As Object
    Dim cell As Range
    Set dict = CreateObject("Scripting.Dictionary")
    For Each cell In rng.Cells
         If Not dict.Exists(cell.Value) Then
            dict.Add cell.Value, 0
        End If
    Next
    CountUnique = dict.Count
End Function

Sample-Delete-Columns-that-have-sam.xlsm

[ fanpages ]

Ryan:
If a worksheet being interrogated contains any columns beyond column 26 ([Z]), then this statement (& the others following that use the same approach) will fail:

LastRow = Cells(Rows.Count, Chr(64 + i)).End(xlUp).Row

ASKER CERTIFIED SOLUTION

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

[ fanpages ]

^ No problem at all. I wasn't "checking up" on you, buddy. Just looking how you addressed the problem raised by the question.

aikimark

I toyed with the idea of using the CountIf() function to identify the columns, but couldn't figure out how to filter the columns. Autofilter only filters rows. I gave up on that idea and packaged it in this routine:

Sub Q_28709011()
    Dim rng As Range
    Dim rngData As Range
    Dim wks As Worksheet
    Dim lngCol As Long
    Set wks = ActiveSheet
    Set rng = wks.Range(wks.Range("A1"), wks.Range("A1").End(xlToRight))
    Application.ScreenUpdating = False
    For lngCol = rng.Cells.SpecialCells(xlCellTypeLastCell).Column To rng.Cells(1, 1).Column Step -1
        Set rngData = wks.Range(rng.Cells(2, lngCol), wks.Cells(wks.Rows.Count, lngCol).End(xlUp))
        If rngData.Rows.Count = WorksheetFunction.CountIf(rngData, wks.Cells(2, lngCol).Value) Then
            wks.Columns(lngCol).Delete
        End If
    Next
    Set rng = wks.UsedRange
    Application.ScreenUpdating = True
End Sub

ASKER

Geniuses, all of you.
Thank you!

ASKER

wait those points should be Ryan's he had the solution initially. yikes how do I change it or at bare minimum split points.

aikimark

Here is a slightly more efficient version of my earlier code

Sub Q_28709011()
    Dim rng As Range
    Dim rngData As Range
    Dim wks As Worksheet
    Dim lngCol As Long
    Dim strRange As String
    Set wks = ActiveSheet
    Set rng = wks.Range(wks.Range("A1"), wks.Range("A1").End(xlToRight))
    Application.ScreenUpdating = False
    For lngCol = 1 To rng.Cells.SpecialCells(xlCellTypeLastCell).Column
        Set rngData = wks.Range(rng.Cells(2, lngCol), wks.Cells(wks.Rows.Count, lngCol).End(xlUp))
        If rngData.Rows.Count = _
            WorksheetFunction.CountIf(rngData, wks.Cells(2, lngCol).Value) Then
            strRange = strRange & "," & wks.Columns(lngCol).Address
        End If
    Next
    strRange = Mid(strRange, 2)
    wks.Range(strRange).Delete
    Set rng = wks.UsedRange
    Application.ScreenUpdating = True
End Sub