VBA - Delete columns based on criteria

[jakobt]

I select a row (in this instance row 7). In this row a lot of entity names are listed - UK and none UK.

I want to delete all columns which does not entail a UK entity name.

All my UK entity names are stored in column A in the filed stored as x:\ukentities.xlsx.sheet1

If any cell in row 7 (the current selected row) does not match the entity names in the UKentities workbook the column should be deleted.

This is an operation I need to do continually, and would like to write a piece of code for it.

 

[kanadaaa]

Try this in a standard module:

Sub DeleteColsBasedOnUKEntities()
    Dim src As Workbook, lr As Long, i As Long, ukEntities() As String, j As Long, lc As Long
    Application.ScreenUpdating = False

    'Change the path in parentheses to the path of ukentities =============
    On Error GoTo errHandler
    Set src = Workbooks.Open("I:\1168282 Delete cols based on values on different workbook\ukentities.xlsx")
    On Error GoTo 0
    '===============================================

    'Get ukentities
    With src.Worksheets("Sheet1")
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        j = 0
        For i = 1 To lr
            If IsArrayEmpty(ukEntities) Then
                ReDim ukEntities(j)
                ukEntities(j) = .Cells(i, "A")
                j = j + 1
            Else
                If IsInArray(.Cells(i, "A").Value, ukEntities) = False Then
                    ReDim Preserve ukEntities(j)
                    ukEntities(j) = .Cells(i, "A")
                    j = j + 1
                End If
            End If
        Next i
    End With

    'Delete columns
    With ThisWorkbook.Worksheets("Sheet1") 'Maybe you need to specify the sheet name here
        lc = .Cells(7, .Columns.Count).End(xlToLeft).Column
        For i = lc To 1 Step -1
            If IsInArray(.Cells(7, i).Value, ukEntities) = False Then
                .Columns(i).Delete
            End If
        Next i
    End With

    src.Close
    Application.ScreenUpdating = True
    MsgBox "Done"
Exit Sub
errHandler:
    Application.ScreenUpdating = True
    MsgBox "Path not found", vbExclamation, "Error"
End Sub

Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError 'array is empty
        For Each element In arr
            If element = valToBeFound Then
                IsInArray = True
                Exit Function
            End If
        Next element
Exit Function
IsInArrayError:
    On Error GoTo 0
    IsInArray = False
End Function

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = True
    IsArrayEmpty = UBound(arr) < LBound(arr)
End Function

 

[kanadaaa]

Revised a little:

Sub DeleteColsBasedOnUKEntities()
    Dim src As Workbook, lr As Long, i As Long, ukEntities() As String, j As Long, lc As Long
    Application.ScreenUpdating = False

    On Error GoTo errHandler
    'Change the path in parentheses to the path of ukentities =============
    Set src = Workbooks.Open("F:\Excel\1168282 Delete cols based on values on different workbook\ukentities.xlsx")
    '===============================================
    On Error GoTo 0

    'Get ukentities
    With src.Worksheets("Sheet1")
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        j = 0
        For i = 1 To lr
            If .Cells(i, "A") <> "" Then
                If IsArrayEmpty(ukEntities) Then
                    ReDim ukEntities(j)
                    ukEntities(j) = .Cells(i, "A")
                    j = j + 1
                Else
                    If IsInArray(.Cells(i, "A").Value, ukEntities) = False Then
                        ReDim Preserve ukEntities(j)
                        ukEntities(j) = .Cells(i, "A")
                        j = j + 1
                    End If
                End If
            End If
        Next i
    End With

    'Delete columns
    With ThisWorkbook.Worksheets("Sheet1") 'Maybe you need to specify the sheet name here
        lc = .Cells(7, .Columns.Count).End(xlToLeft).Column
        For i = lc To 1 Step -1
            If IsInArray(.Cells(7, i).Value, ukEntities) = False Then
                .Columns(i).Delete
            End If
        Next i
    End With

    src.Close
    Application.ScreenUpdating = True
    MsgBox "Done"
Exit Sub
errHandler:
    Application.ScreenUpdating = True
    MsgBox "Source file not found", vbExclamation, "Error"
End Sub

Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError 'array is empty
        For Each element In arr
            If element = valToBeFound Then
                IsInArray = True
                Exit Function
            End If
        Next element
Exit Function
IsInArrayError:
    On Error GoTo 0
    IsInArray = False
End Function

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = True
    IsArrayEmpty = UBound(arr) < LBound(arr)
End Function