Script Inside: Remove All Empty Columns from Sheet

[tradeaccepted]

Hello,

I have a script that I found from KuTools that will help delete all columns that have no data, only a header.

Sub RemoveEmptyFields()
    Dim xEndCol As Long
    Dim i As Long
    Dim xDel As Boolean
    On Error Resume Next
    xEndCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    If xEndCol = 0 Then
        MsgBox "There is no data on """ & ActiveSheet.Name & """ .", vbExclamation, "Kutools for Excel"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For i = xEndCol To 1 Step -1
        If Application.WorksheetFunction.CountA(Columns(i)) <= 1 Then
            Columns(i).Delete
            xDel = True
        End If
    Next
    If xDel Then
        MsgBox "All blank and column(s) with only a header row have now been deleted.", vbInformation, "Kutools for Excel"
    Else
         MsgBox "There are no Columns to delete as each one has more data (rows)  than just a header.", vbExclamation, "Kutools for Excel"
    End If
    Application.ScreenUpdating = False
End Sub

The script runs pretty slow, but it does what I need so im ok with that.
I am trying to add something to this code where after the script is run, it will create a new sheet and that sheet will contain two columns.

1. Columns Removed
2. Columns Kept

The first column will display a list of all the columns that were deleted. The second column will display a list of all the columns that still exist.
Is this possible?

 

[Norie]

Try this.

Sub RemoveEmptyFields()
Dim xEndCol As Long
Dim i As Long
Dim xDel As Boolean
Dim arrKeptCols As Variant
Dim arrDelCols As Variant
Dim cntDel As Long
Dim cntKept As Long

    On Error Resume Next

    xEndCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    If xEndCol = 0 Then
        MsgBox "There is no data on """ & ActiveSheet.Name & """ .", vbExclamation, "Kutools for Excel"
        Exit Sub
    End If

    Application.ScreenUpdating = False

    ReDim arrKeptCols(1 To xEndCol)
    ReDim arrDelCols(1 To xEndCol)

    For i = xEndCol To 1 Step -1
        If Application.WorksheetFunction.CountA(Columns(i)) <= 1 Then
            cntDel = cntDel + 1
            arrDelCols(cntDel) = Cells(1, i).Value & "-" & i
            Columns(i).Delete
            xDel = True
        Else
            cntKept = cntKept + 1
            arrKeptCols(cntKept) = Cells(1, i).Value & "-" & i
        End If
    Next

    If xDel Then
        MsgBox "All blank and column(s) with only a header row have now been deleted.", vbInformation, "Kutools for Excel"
    Else
        MsgBox "There are no Columns to delete as each one has more data (rows)  than just a header.", vbExclamation, "Kutools for Excel"
    End If
    
    Sheets.Add
    
    With ActiveSheet
        .Range("A1:B1").Value = Array("Kept", "Deleted")
        .Range("A2").Resize(xEndCol).Value = Application.Transpose(arrKeptCols)
        .Range("B2").Resize(xEndCol).Value = Application.Transpose(arrDelCols)
    End With
    
    Application.ScreenUpdating = False
    
End Sub

 

[tradeaccepted]

Thank you Norie! Much appreciated for the quick turnaround. I also really like the feature you added which displays the position of the column that was deleted, thank you for that.

One thing that I have never noticed until today is that Excel runs EXTREMELY slow when wrapped text is on. I tried to insert a new column on a sheet with wrapped text and it took 10-15s to insert. When the text is not wrapped it happened instantly.
Same thing with this script. It runs instantly without any text wrapping, but hangs up completely with wrapped text. File has around 5000 rows and 25 columns.

Do you know why this is?

 

[Norie]

Wrapped text where?

 

[tradeaccepted]

The Excel file has around 25 columns, and the wrapped text is in the cells of one specific column, not in the headers.

I would provide an example but the data is sensitive. The actual data is email headers: Email To, From, CC, BCC, Subject, etc etc. So the email To field can sometimes be a large amount of data.
If it doesn't make any sense why text wrapping of the data would cause a huge slowdown, maybe its something local on my end.

 

[The Sisko]

Thanks so much for this. I work with a web app that produces a standard download file that includes every field in the database, empty or not. I've looked for a long time for a script to remove empty columns but was never able to find one that classifies columns with only headers as empty. This script will save me LOTS of time. Thanks again!