VBA - Delete Columns Based on Header Criteria or Empty Cells

[Eitel13]

Also posted here:

https://stackoverflow.com/questions/50251293/vba-find-lastcolumn-and-check-if-first-row-is-empty

Some of the sheets in my workbook do not have headers, so I use the below code to insert a blank row and assign a header to column A - I know column A will always be employee number.

Sub insertRow()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim wkbk1 As Workbook

    Set wkbk1 = Workbooks("testWorkbook.xlsm")

    'Set sheets to be used in each workbook
    Set ws1 = wkbk1.Sheets("mySheet")
    Set ws2 = wkbk1.Sheets("hisSheet")
    Set ws3 = wkbk1.Sheets("herSheet")

    wkbk1.Activate

    ws1.Range("A1").EntireRow.Insert
    ws1.Range("A1").Value = "Employee Number"

    ws2.Range("A1").EntireRow.Insert
    ws2.Range("A1").Value = "Employee Number"

    ws3.Range("A1").EntireRow.Insert
    ws3.Range("A1").Value = "Employee Number"

End Sub

The below code deletes columns based on the header name.

Sub ManipulateSheets()

    Dim a As Long, w As Long
    Dim keepCols As Variant
    Dim wkbk1 As Workbook

    Set wkbk1 = Workbooks("testWorkbook.xlsm")

    keepCols = Array("Employee Number", "Status")

    wkbk1.Activate

    With wkbk1

        For w = 1 To .Worksheets.count

            With Worksheets(w)

                For a = .Columns.count To 1 Step -1

                    If UBound(Filter(keepCols, .Cells(1, a), True, vbTextCompare)) < 0 Then _
                            .Columns(a).EntireColumn.Delete

                Next a

            End With

        Next w

    End With

End Sub

The issue is this:

The 3 sheets that I insert a row in and set the column header for column A to Employee Number, still has empty headers for the remainder of the row.. So when I run the code above to delete the columns, nothing happens on these 3 sheets as there is no data to compare to in the header - the cells are empty..

So the two options I thought would work are:

1. Find the lastColumn and insert text into the cells between column A and the lastColumn

1.1. Find the last column that has data in it​

1.2. Identify the column (lets assume column E) - at this point, we know from column A - E there is data in those columns​

1.3. Set a loop from cell B1 - cell E1 to check if the cells are blank or not (I say cell B1 because I know cell A1 will contain "Employee Number")​

1.4 If the cell is blank, insert the text "blank"​

1.5. When I execute the macro that check column headers, it would therefore be able to check that from column B - E needs to be deleted because it has text and doesn't match the required text in the array​

2. Find the lastColumn and include a criteria in the if statement that looks for blank cells as well as non-matching headers

I got the code to find the lastColumn here:

https://stackoverflow.com/questions/11926972/excel-vba-finding-the-last-column-with-data

Sub findColumn()

    Dim rLastCell As Range
    Dim i As Long
    Dim MyVar As Variant
    Dim ws1 As Worksheet
    Dim wkbk1 As Workbook
    i = 2

    Set wkbk1 = Workbooks("testWorkbook.xlsm")

    Set ws2 = wkbk1.Sheets("ws1")

    Set rLastCell = ws2.Cells.Find(What:="*", After:=ws2.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)

End Sub

I managed to get the below - which removes columns with empty headers and those that do not match the array:

Sub DeleteIrrelevantColumns()

    Dim keepCols()
    Dim unionRng As Range, rng As Range
    Dim ws As Worksheet
    keepCols = Array("Employee Number", "Status")
    Dim wkbk1 As Workbook

    Set wkbk1 = Workbooks("testWorkbook.xlsm")

    For Each ws In wkbk1.Worksheets
        
        With ws
            
            If Application.WorksheetFunction.CountA(.Rows(1)) > 0 Then
                
                For Each rng In Intersect(.Rows(1), .UsedRange)
                    
                    If IsError(Application.Match(rng.Value, keepCols, 0)) Then
                        
                        If Not unionRng Is Nothing Then
                            
                            Set unionRng = Union(unionRng, rng)
                        
                        Else
                            
                            Set unionRng = rng
                        
                        End If
                    
                    End If
                
                Next rng
                
                If Not unionRng Is Nothing Then unionRng.EntireColumn.Delete
                    
                    Set unionRng = Nothing
                                    
                End If
        
        End With
    
    Next ws

End Sub

So the above does work, but, it would appear as though it is getting stuck in an infinite loop. When I break the loop (Ctrl + Break) and I go through the sheets, then I see that it worked. I have tried letting the code just run, but it never stops.

 

[SkipVought]

Hi,

Looking for the cleanest approach...

Sub DeleteIrrelevantColumns()

    Dim keepCol 
    Dim ws As Worksheet
    keepCol = "Status"
    Dim wkbk1 As Workbook
    Dim c As Integer
    Dim rc As Range

    Set wkbk1 = Workbooks("testWorkbook.xlsm")

    For Each ws In wkbk1.Worksheets
        
        With ws
            For c = .UsedRange.Columns.Count to 2 Step -1
               Set rc = .Cells(1, c)
               If rc.Value = “” Then 
                  rc.EntireColumn.Delete
               Else
                  If rc.Value <> keepCol Then
                     rc.EntireColumn.Delete
                  End If
               End If
            Next
        End With
     Next

The “secret” is that when deleting entire column or rows it is best done in reverse, else you loose your way.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Eitel13]

Thank you for your reply Skip..

Just one or two things..

I see in your reply you only using "Status" and not "Employee Number" & "Status".. Would this not delete the columns that have employee number as the header too?

And I believe at the end of your code where you have the "next", it should be "next ws"?

 

[SkipVought]

“Would this not delete the columns that have employee number as the header too?”

No. The loop ends at column 2 as you will note. As you stated, column A ALWAYS has the correct heading.

“And I believe at the end of your code where you have the "next", it should be "next ws"?”

Next is sufficient. Adding [tt]Next c[/tt], is merely optional. In this case with only one loop especially.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Eitel13]

No. The loop ends at column 2 as you will note. As you stated, column A ALWAYS has the correct heading."

Ahhh my apologies, I didn't realize that your code took that into consideration..

Would you please show me where so that I know for future reference how to read it?

I think it could be this line:

 For c = .UsedRange.Columns.count To 2 Step -1

"Next is sufficient. Adding Next c, is merely optional. In this case with only one loop especially."

Thank you for this, I now understand the difference

 

[SkipVought]

“Would you please show me where so that I know for future reference how to read it?”

Show you what?

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[DjangMan]

@Skip: The OP was asking how you told the macro to stop at column 2. He guessed correctly.

 

[Eitel13]

@DjangMan: Yes, that correct. Thank you

@Skip, thank you for your help