Delete all columns if value in row 2 of that column is x?

[Hyflex]

Hi Guys,

I'm looking for the correct way of deleting coulmns based on if row 2 has an x in it..

I have two versions that I tried but im pretty sure there are faster ways of doing it, I don't quite know how to delete all the columns at once.

    '  Version 1
    FurthestRightColumn = Range("IV2").End(xlToLeft).Column
    
    With Range("A2:A" & FurthestRightColumn)
        .SpecialCells(xlCellTypeConstants).EntireColumn.Delete
    End With
    
    '  Version 2
    i = 1
    For y = Range("IV2").End(xlToLeft).Column To i Step -1
        If Cells(2, y).Value = "x" Then
            Columns(y).Delete
        End If
    Next y

The first version doesn't work for some reason and the second column works but is a slow loop, any ideas what to do to make this faster?

[mehmetcik]

Try this:

Sub Macro1()

  Range("A2", Cells(2, Selection.SpecialCells(xlCellTypeLastCell).Column)).Select
    Set rngLook = Selection
    strValueToPick = "x"
    
    With rngLook
        Set rngFind = .Find(strValueToPick, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole)
        If Not rngFind Is Nothing Then
            strFirstAddress = rngFind.Address
            Set rngPicked = rngFind
            Do
                Set rngPicked = Union(rngPicked, rngFind)
                Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
        End If
    End With
    
    If Not rngPicked Is Nothing Then
        rngPicked.EntireColumn.Select
    End If
    
    Selection.Delete Shift:=xlToLeft

End Sub

[Hyflex]

Try this...

snip

I modified yours a bit and I dont quite know how to get it working for the specific worksheet that it's on...

    For Each Worksheet In ThisWorkbook.Worksheets
        If Worksheet.Name <> "int" And Worksheet.Name <> "BOPEL" Then
        
                Worksheet.Activate
                Set rngLook = Range("A2", Cells(2, Selection.SpecialCells(xlCellTypeLastCell).Column))
                strValueToPick = "x"
                
                With rngLook
                    Set rngFind = .Worksheet.Find(strValueToPick, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole)
                    If Not rngFind Is Nothing Then
                        strFirstAddress = rngFind.Address
                        Set rngPicked = rngFind
                        Do
                            Set rngPicked = Union(rngPicked, rngFind)
                            Set rngFind = .FindNext(rngFind)
                        Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
                    End If
                End With
                
                If Not rngPicked Is Nothing Then
                    rngPicked.EntireColumn.Delete Shift:=xlToLeft
                End If
                
            Set rngLook = Nothing
            Set rngFind = Nothing
            Set rngPicked = Nothing
            
            Worksheet.Rows("1:2").Delete ' Shift:=xlUp
            Worksheet.SaveAs SaveToDirectory & Worksheet.Name, xlCSV
        End If
    Next

It seems to do what I want it to do but I surely should be able to do this without having to use Worksheet.Activate?

[Vikas_Gautam]

Try this..

For each cell in Range("A2:" & cells(2,Cells(2,Columns.count).end(xltoleft).Column)))
if cell.value="x" then
cell.entirecolumn.select
selection.delete shift:=xltoleft
end if
next

Don't forget to click *

[millz]

For each cell in Range("A2:" & cells(2,Cells(2,Columns.count).end(xltoleft).Column)))
if cell.value="x" then
cell.entirecolumn.select
selection.delete shift:=xltoleft
end if
next

what about mine..?

If you have tried your code yourself, you will find that it doesn't work.

[kalak]

try

Sub delcols()
On Error Resume Next
With ActiveSheet.Cells.Rows(2)
    .Replace "", Chr(31), xlWhole
    .Replace "x", "", xlWhole
    .SpecialCells(4).EntireColumn.Delete
    .Replace Chr(31), ""
End With
End Sub

[Vikas_Gautam]

or try this..

    For Each cell In Range("A2:" & Cells(2, Columns.Count).End(xlToLeft).Address(False, False))
        If cell.Value = "x" Then
            range(cells(cell.row,cell.column),cells(cells(rows.count,cell.column).end(xlup).row,cell.column)).clearcontents            
        End If
    Next

I have used Clearcontents method..

Don't forget to click *

[Hyflex]

I just made these two trying to use the union function but neither work

    Set Rng = Range("A2:" & Range("IV2").End(xlToLeft).Address(False, False))
    For y = Range("IV2").End(xlToLeft).Column To i Step -1
        If Cells(2, y).Value = "x" Then
            'Columns(y).Delete
            Set Rng = Union(Rng, Cells(2, y))
        End If
    Next y
    
    Rng.EntireColumn.Delete

    Set Rng = Range("A2:" & Range("IV2").End(xlToLeft).Address(False, False))
    FurthestRightColumn = Range("IV2").End(xlToLeft).Column
    For i = 1 To FurthestRightColumnStep
        If Cells(2, i).Value = "x" Then
            'Columns(FurthestRightColumn).Delete
            Set Rng = Union(Rng, Cells(2, i))
        End If
    Next i
    
    Rng.EntireColumn.Delete

However neither work correctly

[Vikas_Gautam]

what about mine..?

Vikas Gautam

[Hyflex]

Try this..

For each cell in Range("A2:" & cells(2,Cells(2,Columns.count).end(xltoleft).Column)))
if cell.value="x" then
cell.entirecolumn.select
selection.delete shift:=xltoleft
end if
next

Don't forget to click *

what about mine..?

Vikas Gautam

Your code doesn't work, the loop is wrong the way I fixed your loop is by doing:

    For Each cell In Range("A2:" & Cells(2, Columns.Count).End(xlToLeft).Address(False, False))
        If cell.Value = "x" Then
            cell.EntireColumn.Select
            Selection.Delete shift:=xlToLeft
        End If
    Next

However even then it still doesn't work because it has a problem I avoided in my first post by stepping backwards from far right to the left... basically if you had B2 and C2 with an x in each cell then when it deletes column B it will make C shift leftwards and then when it cycles it skips and misses C

[Vikas_Gautam]

Try this..then..

    For Each cell In Range("A2:" & Cells(2, Columns.Count).End(xlToLeft).Address(False, False))
        If cell.Value = "x" Then
            cell.EntireColumn.Delete            
        End If
    Next

Don't forget to click *

[HaHoBe]

Hi, Vikas_Gautam,

place an x in 2 cells like C and D and the value in C will stay after your suggestion. Deletion sould either be done from the bottom to the top (or the right to lthe left) or by using a range object and deleting the big range at the end:

Sub SampleOne()
Dim cell As Range
Dim rngBig As Range
For Each cell In Range("A2:" & Cells(2, Columns.Count).End(xlToLeft).Address(False, False))
  If cell.Value = "x" Then
    If rngBig Is Nothing Then
      Set rngBig = cell
    Else
      Set rngBig = Union(rngBig, cell)
    End If
  End If
Next cell
If Not rngBig Is Nothing Then
  rngBig.EntireColumn.Delete
  Set rngBig = Nothing
End If
End Sub

Sub SampleTwo()
Dim lngCol As Long
For lngCol = Cells(2, Columns.Count).End(xlToLeft).Column To 1 Step -1
  With Cells(2, lngCol)
    If .Value = "x" Then
      .EntireColumn.Delete
    End If
  End With
Next lngCol
End Sub

[ Edit ]And of course ClearContents will work properly while Delete won´t..[ /Edit]

Ciao,
Holger

[Vikas_Gautam]

Thanks for the suggetion..

Vikas Gautam