delete columns vba - but ignore 1st row

[John Caines]

Hello All.
I'm trying to find a vba solution to delete all empty (selected range) columns in a spreadsheet,,,but with a twist.
The spreadsheet columns have a header in Row A,,,so technically the column isn't completely empty.

So it's trying to write some vba code to delete all empty columns that have a header (in row A),,, and if nothing is in the column below A, delete the row.
I did find a vba code on the www. here;

How to remove blank columns in Excel

See how to delete blank columns in Excel with a macro, formula or a button-click.

www.ablebits.com

Code was;

Public Sub DeleteEmptyColumns()
    Dim SourceRange As Range
    Dim EntireColumn As Range

    On Error Resume Next

    Set SourceRange = Application.InputBox( _
        "Select a range:", "Delete Empty Columns", _
        Application.Selection.Address, Type:=8)

    If Not (SourceRange Is Nothing) Then
        Application.ScreenUpdating = False

        For i = SourceRange.Columns.Count To 1 Step -1
            Set EntireColumn = SourceRange.Cells(1, i).EntireColumn
            If Application.WorksheetFunction.CountA(EntireColumn) = 0 Then
                EntireColumn.Delete
            End If
        Next

        Application.ScreenUpdating = True
    End If
End Sub

But the above code doesn't take into account the headings in row A.

Is there anyway to modify this code above so I can delete empty columns on a range I select (taking into account the selected range, you'd be ignoring the Row A

Hope the above makes sense and someone can help me out here.

Best regards
John C

 

[Peter_SSs]

I just don't know why it won't work for me.

It won't work for anybody if they are using your data because when it counts the cells with values in the columns it does not get 1. Your 'empty' cells actually contain zero-length strings and so are counted by
Application.WorksheetFunction.CountA(EntireColumn)

In a vacant cell to the right put this formula
=ISTEXT(D2)

In another vacant cell to the right put this formula
=ISTEXT(P20)

Compare the results.

Is there anyway to tweak it just slightly?

Try this

Sub Del_Cols_v2()
  Dim c As Long, rw As Long, TotCols As Long, DelCols As Long
 
  Application.ScreenUpdating = False
  TotCols = Cells(1, Columns.Count).End(xlToLeft).Column
  For c = TotCols To 1 Step -1
    rw = Columns(c).Find(What:="?*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row
    If rw = 1 Then
      DelCols = DelCols + 1
      Columns(c).Delete
    End If
  Next c
  Application.ScreenUpdating = True
  MsgBox "Starting columns: " & vbTab & TotCols & vbLf & _
          "Deleted columns: " & vbTab & DelCols & vbLf & _
          "Final columns: " & vbTab & TotCols - DelCols
End Sub

 

[shinigamilight]

Sub comeout()
        Dim rng As Range
        Dim k As String
        Dim j As Integer
         k = Selection.Address
        On Error Resume Next
        Set rng = Application.InputBox("Enter Range", , k, , , , , 8)

        For j = rng.Columns.Count To 1 Step -1
                If WorksheetFunction.CountBlank(rng.Columns(j)) = (Range("xfd:xfd").Rows.Count) - 1 Then
                    rng.Columns(j).Delete
                End If
        Next j

End Sub

 

[John Caines]

Hi Peter_SSs & shinigamilight,
Many thanks for both your replies, and BTW,,, Merry Christmas to you both (and anyone reading this).

Sorry for my late reply, it's been a hectic day!

1st off, Many thanks again Peter_SSs for your reply and new VBA code.
I've tried it out, and it works brilliantly! Many thanks for this. A real time saver for me.
I see what you mean now about cells appearing to the eye being blank, but in-fact they are not.
I tried your formula;
=ISTEXT(D2)
And it returned TRUE,,, but when I clicked in cell D2 and hit delete, it then changed to FALSE,,, so yes, I see what you now mean Peter_SSs, the cells indeed are not blank.

Many thanks also shinigamilight for your code.
It worked fine, (I select the range, I just highlighted all the columns with headers in my sheet), and it ran perfectly.
So many thanks to you also.

This really will save me huge amounts of time, but if possible, is there any chance Peter_SSs or shinigamilight to have 1 final tweak to your code?
It's my mistake, as I can see there is 1 column that can also be deleted, (which appears often) but I wasn't aware of it / didn't think about this when I 1st posted.

TO DELETE ALSO:
I might have a column (Always has a header in ROW 1),, but the column might have blank cells (Well, as Peter_SSs has pointed out, they are not really blank) , and they might have the number 0 in.
If a column has this, blank cell and 0's in only, it can also be deleted.
Why?
Well, this sheet in a lot of places does a count of the entries in the column to the right of it. So if the whole column has a blank cell or number 0, that column is really nothing, so can be deleted.
If it has blank cells, numbers 0,1,2,3,4,5 etc,, it wouldn't be deleted as there are numbers above 0 in the column.
I hope this makes sense.

If your code could be tweaked Peter_SSs or shinigamilight to also delete these columns (so also search for columns with only blanks and 0's in) it then would be perfect.
The software can actually export over 450 columns of data, so manually finding these and deleting them 1 by 1 is a real pain,, I mean really really!
I include 1 example sheet with 2 columns of data, that just makes clear (I hope) the above

mr-excel-example-sheet-3-Peter_SSs-shinigamilight.xlsx

Shared with Dropbox

www.dropbox.com

I really hope the above makes sense.
Again, thank you both for taking the time to look and help.

I appreciate this very much.

Hope you all have a wonderful Christmas.

Best regards
A very grateful
John C

 

[Peter_SSs]

See how this goes

Sub Del_Cols_v3()
  Dim c As Long, rw As Long, TotCols As Long, DelCols As Long
  
  Application.ScreenUpdating = False
  TotCols = Cells(1, Columns.Count).End(xlToLeft).Column
  For c = TotCols To 1 Step -1
    rw = Columns(c).Find(What:="?*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row
    If rw - WorksheetFunction.CountIf(Columns(c).Resize(rw), 0) - WorksheetFunction.CountBlank(Columns(c).Resize(rw)) = 1 Then
      DelCols = DelCols + 1
      Columns(c).Delete
    End If
  Next c
  Application.ScreenUpdating = True
  MsgBox "Starting columns: " & vbTab & TotCols & vbLf & _
          "Deleted columns: " & vbTab & DelCols & vbLf & _
          "Final columns: " & vbTab & TotCols - DelCols
End Sub

 

[John Caines]

Hello Peter_SSs,
Many thanks again for tweaking your VBA code again.
I've just tested it,,, and it ran perfectly!

Brilliant Peter-SSs,, this is really really brilliant!
I just tested it on a sheet I ran the other day, which had 180 columns of data in. Manually this would have taken me ages, probably an hour I guess.
It just found and deleted 62 columns of data in,, well, maybe 2 seconds, not sure exactly how long it took, but it was quick.

So grateful for this Peter_SSs. This is a wonderful Christmas present!

Have a great day, and hope the New Year brings you and everyone here a lot of joy and happiness.

Best regards
A very very grateful
John C

 

[John Caines]

Hi Peter_SSs
Just to add,
I did try to comment it, as I read you can add a comment by adding a single quote mark at the start of the comment line.
And,,I broke it!
I couldn't even get this right,,,, VBA just doesn't seem to like me much!

Heyho
Best regards
John C

 

[Peter_SSs]

You're comment in the first image is in the correct place and is not the problem. The problem starts where vba has placed the blue block. Somehow you have duplicated a whole section of code. Get rid of the No. 2 section.

 

[John Caines]

Hi Peter_SSs,
Unbelievable! I don't even know how I done that, and didn't realise!
LOL
I need another coffee I think, or something stronger seeing as it's Christmas!

I just wanted to put a credit in, as this is so handy, If anyone else needs it on the software forum (software that this is being used on) I just wanted to credit appropriately.

Very glad you saw the error of my ways.

Cheers Peter_SSs

All the best and have a great day

Best regards
John C

 

[Peter_SSs]

Cheers.