CODEWITHSUNDEEP
vbaexcel
TurboTemple
TurboTemple

Reputation: 35

Excel VBA - Find matching column headings and delete the column

Apologies if this has been answered before, I'm unable to find anything that matches my specific case.

I have a workbook with 18 sheets, and a variable number of columns per sheet starting at B2. Occasionally the program that generates the sheet will create duplicate columns, due to this, I need a macro triggered by button to search each sheet for matching column headers and then delete one of these columns (the whole column, not just the header).

So far I'm pretty stuck, I've been able to delete all matches from any cell in the sheet, which pretty much wipes the entire sheet out. I just need to match headers and then delete the entire column based on that.

Let me know if you need any more information, and thank you for the help!

What I have so far, the code is doing some other stuff too so this needs to continue working. 

    Sub RemoveExtras()

Dim MyRange As Range
Dim ws As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

BadCharacters = Array(Chr(10), Chr(13))
wsNumber = Sheets.Count

For Each ws In Worksheets
    With ws
        For Each MyRange In .UsedRange
            If 0 < InStr(MyRange, Chr(10)) Then
             For Each i In BadCharacters
                MyRange = Replace(MyRange, i, vbNullString)
             Next i
            End If
             For t = 1 To wsNumber
              Columns(t).RemoveDuplicates Columns:=Array(1), Header:=xlYes
              Next t
        Next MyRange
    End With
Next ws

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Upvotes: 0

Views: 1749

Answers (2)

Kelaref
Kelaref

Reputation: 517

Dictionaries are perfect for handling unique values:

Sub RemoveExtras()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim c As Integer, i As Integer, ws As Worksheet
Dim dict As Object


For Each ws In Worksheets

    Set dict = CreateObject("Scripting.Dictionary")
    'Find Last column
    c = ws.UsedRange.Columns.Count

    'Loop backwards
    For i = c To 2 Step -1

        'If column does not exist in dictionary, then add it
        If Not dict.Exists(ws.Cells(2, i).Value) Then
            dict.Add ws.Cells(2, i).Value, 1
        Else
        'Otherwise delete column
            ws.Columns(i).Delete Shift:=xlToLeft
        End If

    Next i
    Set dict = Nothing
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic



End Sub

Here you do not compare every pair of column headers in the sheet. Also this compares headers across all the worksheets, not just duplicates inside one individual sheet.

Upvotes: 1

Arjeel
Arjeel

Reputation: 148

See if this helps you

Sub test()

Dim book As Workbook, sheet As Worksheet, text As String

For Each sheet In Worksheets


    Set MR = Range("B2:Z2") 'change Z2 as per your requirement
    For Each cell In MR
        Set BR = Range("B2:Z2") 'change Z2 as per your requirement
        For Each cell2 In BR
            If cell.Value = cell2.Value Then cell.EntireColumn.Delete
        Next
    Next

Next sheet


End Sub

Upvotes: 1

Related Questions