How to delete columns based on the first two letters of a neighbouring column

Question

I'm trying to write a vba code which will simplify the following kind of data:

Sample	Al %	Al ppm	B %	B ppm	Bi ppm	Bi ppm	Ca ppm	Cl ppm
x	0.58			50	80
y	0.51			65	90
z	0.76			80	150

by comparing the first 2 characters in a column heading so that only the one which contains data further down the column is kept. If there is no data in the column and the first two characters in the header are unique (in this case Ca and Cl) I would like to keep the column. The data set is always in alphabetical order so it should only have to look at the cells either side to check for a identical starting string. The simplification of the above table is shown below.

Sample	Al %	B ppm	Bi ppm	Ca ppm	Cl ppm
x	0.58	50	80
y	0.51	65	90
z	0.76	80	150

I think I can delete rows with identical duplicate headers using something like the bellow code, but I have no idea how to tailor it to the other criteria.

Sub columnfixer
Dim lastCol As Long
Dim thisCol As Long


With Sheets("OUTPUT")
lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
thisCol = 2
  Do While thisCol <= lastCol
     If Application.Match(.Cells(1, thisCol).Value, .Range("1:1"), 0) < thisCol Then
        .Cells(1, thisCol).EntireColumn.Delete xlShiftToLeft
        lastCol = lastCol - 1
     Else
        thisCol = thisCol + 1
     End If
  Loop
  End With
End Sub

Answer 1

Delete Range Blank Columns

Option Explicit

Sub DeleteRangeBlankColumnsTEST()
    
    Const fRow As Long = 2
    Const fCol As Long = 2
    
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("OUTPUT").Range("A1").CurrentRegion

    ' Any data below the range will stay intact.
    DeleteRangeBlankColumns rg, fRow, fCol
    
    ' Any data below the range will also get deleted and shifted.
    'DeleteRangeBlankColumns rg, fRow, fCol, True

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Starting from a column ('FirstColumn') of a range ('rg'),
'               it will delete all range (by default) or worksheet columns
'               ('DeleteEntireColumns = True') of the column ranges whose cells
'               from a row ('FirstRow') to the bottom are blank.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteRangeBlankColumns( _
        ByVal rg As Range, _
        Optional ByVal FirstRow As Long = 1, _
        Optional ByVal FirstColumn As Long = 1, _
        Optional ByVal DeleteEntireColumns As Boolean = False)
    Const ProcName As String = "DeleteRangeBlankColumns"
    On Error GoTo ClearError

    Dim drCount As Long: drCount = rg.Rows.Count - FirstRow + 1
    Dim dcCount As Long: dcCount = rg.Columns.Count - FirstColumn + 1
    
    Dim drg As Range ' Data Range
    Set drg = rg.Cells(FirstRow, FirstColumn).Resize(drCount, dcCount)
    
    Dim durg As Range ' Delete (Union) Range
    Dim dcrg As Range ' Data Colum Range
    
    For Each dcrg In drg.Columns
        If Application.CountBlank(dcrg) = drCount Then ' data column is blank
            If durg Is Nothing Then ' only first cell
                Set durg = dcrg.Cells(1)
            Else ' every cell but the first
                Set durg = Union(durg, dcrg.Cells(1))
            End If
        'Else ' data column is not blank
        End If
    Next dcrg
    
    If durg Is Nothing Then Exit Sub
    
    If DeleteEntireColumns Then
        durg.EntireColumn.Delete xlShiftToLeft
    Else
        Intersect(durg.EntireColumn, rg).Delete xlShiftToLeft
    End If
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

EDIT

• This will identify the columns by the first two characters of their headers.
• If a column is unique (found only once), the column will not get deleted even if it is blank.
• If all 'matching' columns are blank, the left-most is kept.
• Additionally, the 'matching' columns need not be grouped (consecutive).

Sub DeleteColumnsCustomTEST()
    
    Const fRow As Long = 2
    Const fCol As Long = 2
    
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("OUTPUT").Range("A1").CurrentRegion

    ' Any data below the range will stay intact.
    DeleteColumnsCustom rg, fRow, fCol, True
    
    ' Any data below the range will also get deleted and shifted.
    'DeleteColumnsCustom rg, fRow, fCol, True

End Sub

Sub DeleteColumnsCustom( _
        ByVal rg As Range, _
        Optional ByVal FirstRow As Long = 1, _
        Optional ByVal FirstColumn As Long = 1, _
        Optional ByVal DeleteEntireColumns As Boolean = False)
    Const ProcName As String = "DeleteColumnsCustom"
    On Error GoTo ClearError
    
    Set rg = ThisWorkbook.Worksheets("OUTPUT").Range("A1").CurrentRegion
    Dim cCount As Long: cCount = rg.Columns.Count
     
    Dim hrg As Range: Set hrg = rg.Rows(1)
    Dim hData As Variant: hData = hrg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim cKey As Variant
    Dim c As Long
    
    For c = FirstColumn To cCount
        cKey = Left(hData(1, c), 2) ' use only first two characters
        If Not dict.Exists(cKey) Then
            Set dict(cKey) = New Collection ' new collection to hold the columns
        End If
        dict(cKey).Add c ' add characters as key and add column to collection
    Next c
            
    ' Reference the data range (no headers).
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim drg As Range
    Set drg = rg.Resize(rCount - FirstRow + 1).Offset(FirstRow - 1)
    rCount = rCount - 1 ' or rCount = drg.rows.count
    
    Dim durg As Range
    Dim cItem As Variant
    Dim iCount As Long
    Dim i As Long
    Dim cCol As Long
    Dim KeeperFound As Boolean
    
    For Each cKey In dict.Keys
        iCount = dict(cKey).Count
        If iCount > 1 Then
            For i = iCount To 1 Step -1
                cCol = dict(cKey)(i)
                If i = 1 Then
                    If Not KeeperFound Then Exit For
                End If
                If Application.CountBlank(drg.Columns(cCol)) = rCount Then
                    If durg Is Nothing Then
                        Set durg = drg.Cells(cCol)
                    Else
                        Set durg = Union(durg, drg.Cells(cCol))
                    End If
                Else
                    KeeperFound = True
                End If
            Next i
            KeeperFound = False
        'Else ' one column only - do nothing
        End If
    Next cKey
    
    If durg Is Nothing Then Exit Sub
    
    If DeleteEntireColumns Then
        durg.EntireColumn.Delete xlShiftToLeft
    Else
        Intersect(durg.EntireColumn, rg).Delete xlShiftToLeft
    End If

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub