How to delete columns when sum in that columns are zero

[br sie]

Hi everyone there,

Please kindly advice,
i have thousand of columns, i would like to delete the columns if the sum in that columns are equal to Zero, however i would like to still maintain column 1-10, also column 11, 15, 350, and 500 even the sum in that columns are zero.
could anyone advice the code for this.
Thanks.

 

[HaHoBe]

Hi, br sie,

please copy the following code into a standard mdsule and try it on a copy of the workbook. Please mind it will work on the active sheet and start at column 12 as the first 11 columns should be kept:

Sub MrExcel_646890()
Dim lngColumn As Long

Application.ScreenUpdating = False
For lngColumn = 12 To ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column
  Select Case lngColumn
    Case 15, 600, 500
      'do nothing
    Case Else
      If WorksheetFunction.Sum(Cells(1, lngColumn).EntireColumn) = 0 Then
        Cells(1, lngColumn).EntireColumn.Value = vbNullString
      End If
  End Select
Next lngColumn
Application.ScreenUpdating = True
End Sub

Ciao,
Holger

 

[br sie]

Ciao Holger,
Thank You so much for the code, it works (for that column with the sum value ZERO, the zero value in that column deleted, only the column still remain).

How about if i would also like to 'delate' that column (the one with sum is ZERO) as well from the sheet, what code needed to be add?
Thanks to advice.

Ciao,
br sie

 

[HaHoBe]

Hi, br sie,

for any delete start at the end and work up toi the top (reason for this is the counter which then doesn´t need to be corrected when a column is deleted).

Sub MrExcel_646890_2()
Dim lngColumn As Long

Application.ScreenUpdating = False
For lngColumn = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column To 12 Step -1
  Select Case lngColumn
    Case 15, 350, 500
      'do nothing
    Case Else
      If WorksheetFunction.Sum(Cells(1, lngColumn).EntireColumn) = 0 Then
        Cells(1, lngColumn).EntireColumn.Delete Shift:=xlToLeft
      End If
  End Select
Next lngColumn
Application.ScreenUpdating = True
End Sub

Sorry for the 600 - it should read 350.

Ciao,
Holger

 

[br sie]

Many Thanks Holger,
Its working, excellent !!

Ciao,
br sie