Sub deleteColumns()
    ColumnName = Cells(2, ActiveCell.Column)
    For Each Cell In Intersect(Rows(2), ActiveSheet.UsedRange)
        If Cell = ColumnName Then
            If IsEmpty(DeleteRange) Then
                Set DeleteRange = Cell
            Else
                Set DeleteRange = Union(DeleteRange, Cell)
            End If
        End If
    Next
    DeleteRange.EntireColumn.Select
    If MsgBox("Удалить выделенные столбцы?", vbYesNo + 32) = vbYes Then
        DeleteRange.EntireColumn.Delete
    End If
End Sub

ActiveCell.Value = CDate(ActiveCell)