CODEWITHSUNDEEP
vbaexcel
Tanzir Rahman
Tanzir Rahman

Reputation: 185

Loop through each column and delete columns with "0"

I'm not getting any errors but it's not deleting the columns with "0's". I just want to delete columns that have lots of 0's as you can read from my code. I'm not sure what could be wrong so any suggestions are welcome.

Sub Finalize()
Dim finalform As Worksheet
Dim deletename As String
Dim finalworkbook As Workbook
Dim ws As Worksheet
Dim copyrange As Range
Dim columnloop As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set finalform = Workbooks(ActiveWorkbook.Name).ActiveSheet

For a = 3 To 18

If Range("B" & a).Value <> "" Then
    Workbooks.Open finalform.Range("B" & a).Value
    Set finalworkbook = Workbooks(ActiveWorkbook.Name)

        'Delete sheets
        For b = 3 To 12
        deletename = finalform.Range("D" & b).Value
        If deletename <> "" Then
        finalworkbook.Worksheets(deletename).Delete
        End If
        Next b

        'Find, replace, remove
        For Each ws In ActiveWorkbook.Worksheets

            'Copy paste values
            Set copyrange = ws.Cells
            copyrange.Copy
            copyrange.PasteSpecial xlPasteValues
            Application.CutCopyMode = False

            'Delete columns with 0
            For Each columnloop In copyrange.Columns
            d = 0
                For c = 1 To 35
                If Cells(c, columnloop.Column).Value = "0" Then
                d = d + 1
                End If
                Next c
            If d > 5 Then
            columnloop.Delete
            End If
            Next columnloop

        Next ws
End If
Next a

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Upvotes: 1

Views: 1029

Answers (1)

user4039065
user4039065

Reputation:

Your loop can be replaced with more efficient methods of counting. You should always start at the extents when deleting rows or columns and work toward A1 in order that you do not skip over a column during the next incrementation.

Dim c As Long, ws As Worksheet

'Find, replace, remove
For Each ws In ActiveWorkbook.Worksheets
    With ws
        .UsedRange.Cells = .UsedRange.Cells.Value
       'Delete columns with 0
        For c = .UsedRange.Columns.Count To 1 Step -1
            If Application.CountIf(.Columns(c), 0) > 5 Then
                .Columns(c).EntireColumn.Delete
            End If
        Next c

    End With
Next ws

There are several other areas that could be tweaked. Once this is running to an operational standard, consider posting it on Code Review (Excel) for further improvements.

Upvotes: 3

Related Questions