Удалить весь столбец, если столбец состоит только из нулей и пустых значений

Question

Мне было интересно, может ли кто-нибудь помочь мне с этой проблемой Excel VBA, с которой я столкнулся,

Я пытаюсь удалить столбец, если столбец имеет только 0 и пустые значения, формат выглядит следующим образом:

Как я уже выделил, два столбца имеют только нулевые и пустые значения, и эти 2 столбца следует удалить.

Формат столбца Excel

У меня есть пробовал этот код, но, к сожалению, он удаляет все столбцы:

Sub dynamicRange()
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False

        Dim startCell As Range, lastRow As Long, lastCol  As Long, ws As Worksheet

        Set ws = ActiveSheet
        Set startCell = Range("E9")

            lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
            lastCol = ws.Cells(startCell.Row, ws.Columns.Count).End(xlToLeft).Column

            ws.Range(startCell, ws.Cells(lastRow, lastCol)).Select

                Set a = Selection

                    For Each cell In a
                        If cell.Value = "Total" Or cell.Value = "Tag" Or cell.Value = "Delivery Fee" Or cell.Value = "CC/Cash" Or cell.Value = "Postcode" Then
                                cell.EntireColumn.Delete
                        End If
                    Next cell

                    For Each cell In a
                        If cell.Value = 0 Or cell.Value = "" Then
                                cell.EntireColumn.Delete
                        End If
                    Next cell

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

С нетерпением ждем решения, спасибо.

Answer 1

Если вы хотите удалить столбцы без значения, вы можете использовать собственную функцию SUM () в Excel с простым кодом, как показано ниже.

Sub DynamicRange()

    Dim startCell As Range
    Dim SumRng As Range
    Dim lastRow As Long, lastCol  As Long
    Dim C As Long

    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    With ActiveSheet
        Set startCell = .Range("E9")
        lastRow = .Cells(.Rows.Count, startCell.Column).End(xlUp).Row
        lastCol = .Cells(startCell.Row, .Columns.Count).End(xlToLeft).Column

        For C = lastCol To startCell.Column Step -1
            Set SumRng = .Range(.Cells(startCell.Row, C), .Cells(lastRow, C))
            If Application.Sum(SumRng) = 0 Then .Columns(C).Delete
        Next C
    End With

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Я не уверен, что понимаю значение вашего startCell на Е9 правильно. В этом отношении ваш код не соответствует изображению вашего рабочего листа. Мой код игнорирует значения, которые находятся выше строки 9, но это было бы очень легко изменить. Просто дай мне знать. Дело в том, что использование функции SUM () заставляет код работать намного быстрее, чем проверка каждой ячейки.

Answer 2

вы можете использовать количество подсчитанных ячеек в диапазоне

WorksheetFunction.CountA(range)

Это пример кода

sub test()
   dim lasCol as integer
   lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

   for i = lastCol to 1 Step - 1
      if worksheetfunction.countA(Columns(i)) = 0 then
         Columns(i).delete
      end if 
   next i

end sub

Конечно, вы можете изменить Столбец на Диапазон, чтобы проверить его содержимое или нет это соответствует вашему файлу. например,

if worksheetfunction.countA(range("A2:A10, A15:A20")) = 0 then

или

if worksheetfunction.countA(range(cells(2,i), cells(10,i))) + worksheetfunction.countA(range(cells(15,i), cells(20,i)))= 0 then

Answer 3

Удалить пустые столбцы

Option Explicit

Sub DeleteEmptyColumns()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim rng As Range, URng As Range, startCell As Range
    Dim lastRow As Long, lastCol As Long, ws As Worksheet
    Dim j As Long   ' Column Counter
    Dim i As Long   ' Row Counter

    On Error GoTo ProgramError

    Set ws = ActiveSheet
    Set startCell = ws.Range("E9")

    lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
    lastCol = ws.Cells(startCell.Row, ws.Columns.Count).End(xlToLeft).Column

    For j = startCell.Column To lastCol
        For i = startCell.Row To lastRow
            Set rng = ws.Cells(i, j)
            If rng.Value <> 0 And rng.Value <> "" Then Exit For
        Next
        If i > lastRow Then Set rng = ws.Cells(1, j): GoSub UnionRange
    Next

'    ' While developing such a code, use Hidden instead of Delete.
'    If Not URng Is Nothing Then URng.EntireColumn.Hidden = True

    If Not URng Is Nothing Then URng.EntireColumn.Delete

    MsgBox "Operation finished successfully."

SafeExit:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = True

Exit Sub

UnionRange:
    If Not URng Is Nothing Then
        Set URng = Union(URng, rng)
    Else
        Set URng = rng
    End If
    Return

ProgramError:
    MsgBox "An unexpected error occurred."
    On Error GoTo 0
    GoTo SafeExit

End Sub