删除带有空白标题的列 VBA

Question

I am looking for assistance in deleting two columns within my range of data that have blank headers. These blank headers will appear in the first row of my used range. What would be the best way to go about this? Should I use.Find to search for blank cells in the first row and then get the column address of the two blank cells in order to delete them?

Currently, I am just deleting the columns that I know they'll appear in, but this has the potential to change. Current code:

rngUsed.Columns("F").Delete
rngUsed.Columns("H").Delete

Because the data can change, what would be the better way of handling this?

Thanks!

Answer 1

You can use SpecialCells to find the blanks in the first row and remove the corresponding columns:

Dim rng As Range

Set rng = Range("B3").CurrentRegion 'for example...

On Error Resume Next 'ignore error if no blanks
rng.Rows(1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
On Error GoTo 0 'stop ignoring errors

Answer 2

Delete Columns With Blank Headers

• The current setup is in Test Mode ie it will select the columns to be deleted. If the result is satisfactory, switch to Const TestMode As Boolean = False when the columns will be deleted.
• Adjust the values in the constant sections.

The Code

Option Explicit

Sub TESTdeleteBlankHeadered()
    
    Const wsName As String = "Sheet1"
    Const ColumnsCount As Long = 2 ' -1 - all columns containing blank headers.
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim rg As Range: Set rg = wb.Worksheets(wsName).UsedRange
    
    deleteBlankHeadered rg, ColumnsCount ' first found columns
    'deleteBlankHeadered rg, ColumnsCount, True ' last found columns
    'deleteBlankHeadered rg ' all found columns

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a worksheet, deletes a specified number of its columns,
'               defined by blank cells in the first (header) row of
'               a given range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub deleteBlankHeadered( _
        rg As Range, _
        Optional ByVal ColumnsCount As Long = -1, _
        Optional ByVal LastOccurringColumns As Boolean = False)
        
    ' When 'True', tests with select.
    ' When 'False', deletes.
    Const TestMode As Boolean = True
        
    ' Validate inputs.
    If rg Is Nothing Then Exit Sub
    If ColumnsCount < -1 Or ColumnsCount = 0 Then Exit Sub
    
    ' Define Source Row Range.
    Dim srg As Range: Set srg = rg.Areas(1).Rows(1)
    
    ' Write values from Source Row Range to Data Array.
    Dim cCount As Long: cCount = srg.Columns.Count
    Dim Data As Variant
    If cCount > 1 Then
        Data = srg.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
    End If
    
    ' Define 'elements' of the 'For...Next' Loop.
    Dim cFirst As Long, cLast As Long, cStep As Long
    If LastOccurringColumns Then
        cFirst = cCount: cLast = 1: cStep = -1
    Else
        cFirst = 1: cLast = cCount: cStep = 1
    End If
    
    ' Declare additional variables.
    Dim drg As Range ' Delete Range
    Dim oCount As Long ' Occurrences Count
    Dim j As Long ' Data Array (Source Row Range) Columns Counter
    
    ' Loop through columns of Data Array and use found blank values
    ' to combine blank cells with Delete Range.
    For j = cFirst To cLast Step cStep
        If Not IsError(Data(1, j)) Then
            If Len(Data(1, j)) = 0 Then
                oCount = oCount + 1
                Select Case oCount
                    Case 1
                        Set drg = srg.Cells(j)
                        If ColumnsCount = 1 Then
                            Exit For
                        End If
                    Case ColumnsCount
                        Set drg = Union(drg, srg.Cells(j))
                        Exit For
                    Case Else
                        Set drg = Union(drg, srg.Cells(j))
                End Select
            End If
        End If
    Next
    
    ' Declare additional variables.
    Dim ActionTaken As Boolean
    
    ' Delete Column Ranges (containing blank headers).
    If Not drg Is Nothing Then
        Application.ScreenUpdating = False
        If TestMode Then
            drg.Worksheet.Activate
            drg.EntireColumn.Select
        Else
            drg.EntireColumn.Delete
        End If
        Application.ScreenUpdating = True
        ActionTaken = True
    End If
    
    ' Inform user.
    If ActionTaken Then
        MsgBox "Columns deleted: " & oCount, vbInformation, "Success"
    Else
        MsgBox "No columns deleted.", vbExclamation, "No Action Taken"
    End If

End Sub