Keep only certain named columns in a ws, delete the rest

[VBAProIWish]

Hello, I need code to keep only certain columns by name and delete the rest.
See below for a better explanation and thanks!

 

[John_w]

Try this:

Public Sub Delete_Named_Columns()

    Dim columnName As Variant, col As Variant
    
    With ActiveSheet
        For Each columnName In Array("Color", "Depth", "Height")
            col = Application.Match(columnName, .Rows(1), 0)
            If Not IsError(col) Then .Columns(col).Delete
        Next
    End With

End Sub

 

[VBAProIWish]

Thanks for the code , John!

It's actually doing the exact opposite of what I want, which in the programming world, I know that we are close!

Using your line of code here...

For Each columnName In Array("Color", "Depth", "Height")

Would mean that those are the columns I want to keep, deleting all other columns. There are times when I may have multiple columns and different column names so any column names I define in the array need to be the columns to keep.



I tried to change remove the "Not" from this part of your code, but it didn't work...

If Not IsError(col) Then .Columns(col).Delete

What needs to be changed to get this to keep the column names in the array instead of deleting them?

Thanks much!

 

[John_w]

What needs to be changed to get this to keep the column names in the array instead of deleting them?

A different approach is needed.

Public Sub Keep_Named_Columns()
   
    Dim col As Long
    Dim keepColumnNames As String
   
    keepColumnNames = ",Size,Width,Length,"
    With ActiveSheet
        For col = .Cells(1, .Columns.Count).End(xlToLeft).Column To 1 Step -1
            If InStr(1, keepColumnNames, "," & .Cells(1, col).Value & ",", vbTextCompare) = 0 Then .Columns(col).Delete
        Next
    End With

End Sub

This will keep multiple columns with the same name specified in the keepColumnNames string and delete all others that aren't in the string.

 

[jolivanes]

Delete all Columns except 3 as indicated.

Sub Keep_Some()
Dim i As Long
Application.ScreenUpdating = False
    For i = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        Select Case Cells(1, i).Value
            Case "Size", "Width", "Length"
                Case Else
            Cells(1, i).EntireColumn.Delete
        End Select
    Next i
Application.ScreenUpdating = True
End Sub

 

[VBAProIWish]

It's really fascinating to me how 2 completely different sets of code can accomplish the same task!

I really wish I could mark both answers as the solution but will give the solution to John since he was the first replier.

Thank you both so much!

 

[jolivanes]

Another way of doing it.

Sub Keep_Some_2()
Dim x As Long, cols As Range, lc As Long, lr As Long
lr = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
For x = 1 To lc
    If Cells(1, x).Value <> "Size" And Cells(1, x).Value <> "Width" And Cells(1, x).Value <> "Length" Then
        If cols Is Nothing Then
            Set cols = Columns(x).EntireColumn
                Else
            Set cols = Union(cols, Columns(x)).EntireColumn
        End If
    End If
Next x
If Not cols Is Nothing Then Intersect(cols.Columns, Rows("1:" & lr)).Delete    'Select    '<----- Change to Delete.
End Sub

 

[VBAProIWish]

Very interesting, jolivanes. Yet a third way!

 

[jolivanes]

Another possibility to keep in your "keepsakes" folder
Along the lines of John's solution in Post #2.

Sub With_Array()
Dim myArr, opArr, i As Long
opArr = Array("Size", "Width", "Length")    '<----- Return Columns in this order
myArr = Sheets("Sheet1").Cells(1).CurrentRegion.Value
Sheets("Sheet1").Cells(1).CurrentRegion.ClearContents
    For i = LBound(opArr) To UBound(opArr)
        Sheets("Sheet1").Cells(1, i + 1).Resize(UBound(myArr)) = Application.Index(myArr, , Application.Match(opArr(i), Application.Index(myArr, 1, 0), 0))
    Next i
End Sub