VBA, changing Columns for Rows

[Farback]

I use this code to look down coumn C and to delete any row that had "Value A" or "Value" in it:

Sub Delete_Surplus_Rows()
Dim FindString As String
Dim iRow As Long
Dim LastRow As Long
Dim FirstRow As Long
Dim CalcMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
FirstRow = 4
With ActiveSheet
.DisplayPageBreaks = False
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow Step -1

If IsError(.Cells(iRow, "C").Value) Then
'Do nothing
'This avoids an error if there is a error in the cell
ElseIf .Cells(iRow, "C").Value = "Value A" Then
.Rows(iRow).Delete
ElseIf .Cells(iRow, "C").Value = "Value B" Then
.Rows(iRow).Delete
End If

Next iRow

End With
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

In another spreadsheet, I now need to look along row 3 for two values, say "Value C" and "Value B", and to delete the columns that contain them. How do I amend my code to do this?

 

[rdw72777]

Try this:

Sub Delete_Surplus_Columns()

Dim FindString As String
Dim iCol As Long, LastCol As Long, FirstCol As Long
Dim CalcMode As Long

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

FirstCol = 1
With ActiveSheet
    .DisplayPageBreaks = False
    
    LastCol = .Cells(3, Columns.Count).End(xlToLeft).Column
    
    For iCol = LastCol To FirstCol Step -1
    
        If IsError(.Cells(3, iCol).Value) Then
        'Do nothing
        'This avoids an error if there is a error in the cell
        ElseIf .Cells(3, iCol).Value = "Value B" Then
        .Columns(iCol).Delete
        ElseIf .Cells(3, iCol).Value = "Value C" Then
        .Columns(iCol).Delete
        End If
    
    Next iCol

End With

With Application
    .ScreenUpdating = True
    .Calculation = CalcMode
End With

End Sub

 

[Farback]

Thank you Ryan, that is just what I was after.

 

[Weaver]

Here's an alternative way which should make it easier to add more criteria. It also does all the deleting in one go and won't error if there are error cells in the range.

Sub deleteCols()
    Dim delArray As Variant, delRange As Range, addr As String
    Dim str As Variant, found As Range, delCols As Range
    delArray = Array("Value A", "Value B")
    Set delRange = Rows(3)
    For Each str In delArray
        Set found = delRange.Find(what:=str)
        If Not found Is Nothing Then
            addr = found.Address
            Do
                If delCols Is Nothing Then
                    Set delCols = found
                Else
                    Set delCols = Union(delCols, found)
                End If
                Set found = delRange.FindNext(found)
            Loop While addr <> found.Address
        End If
    Next str
    If Not delCols Is Nothing Then delCols.EntireColumn.Delete
End Sub

 

[Farback]

Weaver, many thanks for that. Gives me a couple of options to work with.

 

[Farback]

FAO Weaver, Re: VBA, changing Columns for Rows

You very kindly gave me the above code for deleting columns with certain stated values - "Value A", "Value B" etc - in row 3:

Is there a way of amending this to delete all columns with entries in column 3 EXCEPT those with certain values - "Value A", "Value B" etc?
<!-- / message -->

 

[Weaver]

try this:

change

If Not delCols Is Nothing Then delCols.EntireColumn.Delete

to

If Not delCols Is Nothing Then
    delCols.EntireColumn.Hidden = True
    delRange.SpecialCells(xlCellTypeVisible).EntireColumn.Delete
    Cells.EntireColumn.Hidden = False
End If

Although I should point out this won't work properly if there are columns hidden for other reasons, but you still want to delete them

 

[Farback]

Many thanks again Weaver, that has done the trick.

 

[Weaver]

No problem - thanks for the feedback.

 

[Farback]

FAO Weaver Re: VBA, changing Columns for Rows

Your code works so well I adapted it back to use it to delete unwanted rows:
Sub deleteRows()
Dim delArray As Variant, delRange As Range, addr As String
Dim str As Variant, found As Range, delRows As Range
delArray = Array("Activity 1", "Activity 2")
Set delRange = Columns(3)
For Each str In delArray
Set found = delRange.Find(what:=str)
If Not found Is Nothing Then
addr = found.Address
Do
If delRows Is Nothing Then
Set delRows = found
Else
Set delRows = Union(delRows, found)
End If
Set found = delRange.FindNext(found)
Loop While addr <> found.Address
End If
Next str
If Not delRows Is Nothing Then
delRows.EntireRow.Hidden = True
delRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
Cells.EntireRow.Hidden = False
End If
End Sub
This works fine, except that it also deletes headings and the title row. What code would I add to only delete unwanted rows below Row 4?