EXCEL :: Delete columns if each cell's values are the same

I have spreadsheets that often contain columns that are nothing more than repeating value's.  Typically, I would like to simply delete those values.  Could you please help me with a macro or method to easily delete all these columns.  It would need to ignore the header row.  Here is an image of a few of these columns that I would like to remove.

2015-08-26-1933.png
Thank you for your time in advance!
K.B.
LVL 8
K BAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongCommented:
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
0
K BAuthor Commented:
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.
0
Ryan ChongCommented:
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

Open in new window

0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

K BAuthor Commented:
Thank you.. I get an error

2015-08-26-2206.png
on this line

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

Open in new window

0
K BAuthor Commented:
Here is a sample file attached...
Sample-Delete-Columns-that-have-sam.xlsm
0
Ryan ChongCommented:
this works fine with me.
Sample-Delete-Columns-that-have-sam.xlsm
0
K BAuthor Commented:
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....
before.png
AFTER....
after.png
0
Ryan ChongCommented:
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

Open in new window

Sample-Delete-Columns-that-have-sam.xlsm
0
[ fanpages ]IT Services ConsultantCommented:
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
0
Ryan ChongCommented:
ok, tks for highlighting [fanpages], you always got good observation

try this instead:

Sub RemoveDupCols()
    Application.ScreenUpdating = False
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = lastCol To 1 Step -1
        LastRow = Cells(Rows.Count, getColName(i)).End(xlUp).Row
        uniqueCount = CountUnique(ActiveSheet.Range(getColName(i) & "$2:" & getColName(i) & "$" & LastRow))
        Debug.Print "Column " & getColName(i) & "'s unique values count:" & uniqueCount
        If uniqueCount = 1 Then
            Columns(getColName(i)).Delete Shift:=xlToLeft
        End If
    Next
    Application.ScreenUpdating = True
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

Public Function getColName(ByVal colN As Integer) As String
    getColName = Left(Cells(1, colN).Address, Len(Cells(1, colN).Address) - 2)
End Function

Open in new window

Sample-Delete-Columns-d.xlsm
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
[ fanpages ]IT Services ConsultantCommented:
^ No problem at all.  I wasn't "checking up" on you, buddy.  Just looking how you addressed the problem raised by the question.
0
aikimarkCommented:
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

Open in new window

0
K BAuthor Commented:
Geniuses, all of you.
Thank you!
0
K BAuthor Commented:
wait those points should be Ryan's he had the solution initially. yikes how do I change it or at bare minimum split points.
0
aikimarkCommented:
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

Open in new window

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.