Macro to filter each column for cells that appear empty, clear the contents and move to the next column for entire table

[sspatriots]

Hi,

I've been tinkering with the code below to do just as the description states, however, it just runs for ever and I end up stopping the code by killing the excel application. It seems as if it is stuck i a continuous loop. Also, I will provide a bit of code beneath that where I recorded what I want to do on the first 4 or 5 columns. This table has many columns, so I'd like to figure out how to make the first code work. I'm at at loss on this because I have messed with it for over 2 hours now. Any suggestions would be welcome. Thanks, SS

Sub DeleteBlanksInTableColumns()
    Dim tbl As ListObject
    Dim col As ListColumn
    Dim rng As Range
    Dim cell As Range
    
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .CutCopyMode = False
'    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With

    ' Set the table (change "Table1" to your actual table name)
    Set tbl = ActiveSheet.ListObjects("HVG2JobList")
    
    ' Loop through each column in the table
    For Each col In tbl.ListColumns
        ' Filter for blanks in the current column
        col.DataBodyRange.AutoFilter Field:=1, Criteria1:="="
        
        ' Set the filtered range
        
    If Not rng Is Nothing Then
        Set rng = col.DataBodyRange.SpecialCells(xlCellTypeVisible)
        
       
        ' Delete the blank cells
        For Each cell In rng
            If cell.Value = "" Then
                cell.ClearContents
            End If
        Next cell
        
        ' Clear the filter
        tbl.AutoFilter.ShowAllData
        
    End If
        
    Next col
       
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .CutCopyMode = False
'    .DisplayAlerts = True
    .Calculation = xlAutomatic
End With
    
End Sub

Recorded code on first few columns to do what I want:

Sub Macro6()
'
' Macro6 Macro
'

'

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .CutCopyMode = False
'    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With

    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=1
    Range("HVG2JobList[[#Headers],[Job Name]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=2
    Range("HVG2JobList[[#Headers],[G1" & Chr(10) & "Job '#]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=3, Criteria1 _
        :="="
    Range("C26:C1621").Select
    Selection.ClearContents
    Range("HVG2JobList[[#Headers],[G1" & Chr(10) & "Job '#]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=3
    Range("HVG2JobList[[#Headers],[G1 RLSD To" & Chr(10) & "PROD Date]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=4, Criteria1 _
        :="="

    Range("D3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("HVG2JobList[[#Headers],[G1 RLSD To" & Chr(10) & "PROD Date]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=4
    Range("HVG2JobList[[#Headers],[G1 MFG" & Chr(10) & "SCHED" & Chr(10) & "Due Date]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=5, Criteria1 _
        :="="
    Range("E3").Select
    Selection.ClearContents
    Range("HVG2JobList[[#Headers],[G1 MFG" & Chr(10) & "SCHED" & Chr(10) & "Due Date]]").Select
    ActiveSheet.ListObjects("HVG2JobList").Range.AutoFilter Field:=5
    Range("A3").Select

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .CutCopyMode = False
'    .DisplayAlerts = True
    .Calculation = xlAutomatic
End With

End Sub

 

[bobsan42]

try like this:

Sub DeleteBlanksInTableColumns()
    Dim tbl As ListObject
    Dim col As ListColumn
    Dim rng As Range
    Dim cell As Range
    
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .CutCopyMode = False
'    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With

    ' Set the table (change "Table1" to your actual table name)
    Set tbl = ActiveSheet.ListObjects("HVG2JobList")
    
    ' Loop through each column in the table
    For Each col In tbl.ListColumns
        Set rng = Nothing
        ' Filter for blanks in the current column
        col.DataBodyRange.AutoFilter Field:=col.Index, Criteria1:="="

        On Error Resume Next
        ' Set the filtered range
        Set rng = col.DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not rng Is Nothing Then
            rng.ClearContents
        End If

        ' Clear the filter
        tbl.AutoFilter.ShowAllData
            
    Next col
       
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .CutCopyMode = False
'    .DisplayAlerts = True
    .Calculation = xlAutomatic
End With
    
End Sub

 

[Kaper]

Note that in the registered code Selection.ClearContents is used, for whole visible filtered-out data, while you delete cell by cell. Which is obviously much slower way.

Edit: bobsan42 also noted this and included in the code

 

[sspatriots]

try like this:

Sub DeleteBlanksInTableColumns()
    Dim tbl As ListObject
    Dim col As ListColumn
    Dim rng As Range
    Dim cell As Range
   
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .CutCopyMode = False
'    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With

    ' Set the table (change "Table1" to your actual table name)
    Set tbl = ActiveSheet.ListObjects("HVG2JobList")
   
    ' Loop through each column in the table
    For Each col In tbl.ListColumns
        Set rng = Nothing
        ' Filter for blanks in the current column
        col.DataBodyRange.AutoFilter Field:=col.Index, Criteria1:="="

        On Error Resume Next
        ' Set the filtered range
        Set rng = col.DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
       
        If Not rng Is Nothing Then
            rng.ClearContents
        End If

        ' Clear the filter
        tbl.AutoFilter.ShowAllData
           
    Next col
      
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .CutCopyMode = False
'    .DisplayAlerts = True
    .Calculation = xlAutomatic
End With
   
End Sub

That is perfect. Thanks so much for looking at this for me. Much appreciated...