Hi,
Have just changed jobs and gone from E2002 to E2000. One of the more annoying aspects is that you can't delete or insert columns with a filter on, this code allows you to do both.
You just need to select a single cell in the column you wish to delete/position you want to insert.
I know most people won't be working for dinosaur companies with old technology
, but hopefully this will help someone...
Regards, Iain
This function is called in the routine, so posted for completeness:
Have just changed jobs and gone from E2002 to E2000. One of the more annoying aspects is that you can't delete or insert columns with a filter on, this code allows you to do both.
You just need to select a single cell in the column you wish to delete/position you want to insert.
I know most people won't be working for dinosaur companies with old technology
, but hopefully this will help someone...Regards, Iain
Code:
Public Sub Delete_While_Filtered()
Dim rngFilter As Range
Dim arrCriteria
Dim arrFilter1
Dim arrFilter2
Dim arrFilterOperator
Dim strColLett As String
Dim strLastCol As String
Dim i As Integer
Dim x As Integer
Dim c As Integer
Dim a As Integer
Dim intNumCols As Integer
Set rngFilter = ActiveCell.CurrentRegion
i = 1
x = 0
'Are filters on?
If ActiveSheet.AutoFilterMode = False Then Exit Sub
'------------------------------------------------------
'if the column being deleted is the active column we'll
'need to take this into account later...
'------------------------------------------------------
c = ActiveCell.Column
'Are any filters applied?
For i = 1 To rngFilter.Worksheet.AutoFilter.Filters.Count
If rngFilter.Worksheet.AutoFilter.Filters(i).On = True Then
x = x + 1
Else
End If
Next i
'Reset the counter for use later
i = 1
'Are filters active?
If x > 0 Then
'------------------------------------------------
'Loop through the filters, appending the criteria
'------------------------------------------------
Do Until i = rngFilter.Worksheet.AutoFilter.Filters.Count + 1
'Is the filter on?
If rngFilter.Worksheet.AutoFilter.Filters(i).On = True Then
'----------------------------------
'Add the column number to the array
'----------------------------------
'First check to see if this is the column to be deleted
'If so, exit the array filling section as we don't need
'to preserve the filter criteria
If i = c Then GoTo tagSkipActiveColumn
'-----------------------------------------------------------
'set the column value for the array, because when the active
'column is deleted, the columns to the right will decrease
'in number by 1
'-----------------------------------------------------------
If i < c Then 'before the active column
a = i
Else 'after the active column
a = i - 1
End If
'Check to see if it's first time around
If Not IsArray(arrCriteria) Then
ReDim arrCriteria(0)
arrCriteria(UBound(arrCriteria)) = a
Else
ReDim Preserve arrCriteria(UBound(arrCriteria) + 1)
arrCriteria(UBound(arrCriteria)) = a
End If
'------------------------------------
'Redimension the three criteria arrays
'------------------------------------
'Check to see if it's first time around
If Not IsArray(arrFilter1) Then
'It is, instantiate the array
ReDim arrFilter1(0)
Else
'It's not, just add a new element
ReDim Preserve arrFilter1(UBound(arrFilter1) + 1)
End If
'Ditto
If Not IsArray(arrFilter2) Then
ReDim arrFilter2(0)
Else
ReDim Preserve arrFilter2(UBound(arrFilter2) + 1)
End If
'Ditto
If Not IsArray(arrFilterOperator) Then
ReDim arrFilterOperator(0)
Else
ReDim Preserve arrFilterOperator(UBound(arrFilterOperator) + 1)
End If
'Is there an operator?
If (rngFilter.Worksheet.AutoFilter.Filters(i).Operator = xlOr Or rngFilter.Worksheet.AutoFilter.Filters(i).Operator = xlAnd) Then
'If so, add both criteria values to the array
arrFilterOperator(UBound(arrFilterOperator)) = rngFilter.Worksheet.AutoFilter.Filters(i).Operator
arrFilter1(UBound(arrFilter1)) = rngFilter.Worksheet.AutoFilter.Filters(i).Criteria1
arrFilter2(UBound(arrFilter2)) = rngFilter.Worksheet.AutoFilter.Filters(i).Criteria2
Else
'Just add Criteria1
arrFilterOperator(UBound(arrFilterOperator)) = Null
arrFilter1(UBound(arrFilter1)) = rngFilter.Worksheet.AutoFilter.Filters(i).Criteria1
arrFilter2(UBound(arrFilter2)) = Null
End If
Else
End If
tagSkipActiveColumn:
i = i + 1
Loop
'----------------------------------------------------------------------------
'Gone through all of the filters, now take them all off and delete the column
'----------------------------------------------------------------------------
ActiveSheet.AutoFilterMode = False
strColLett = Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2)
ActiveSheet.Columns(strColLett & ":" & strColLett).Delete
'--------------------------------------------------
'Now reapply all of the filters that were on before
'--------------------------------------------------
'first turn the filters back on for all of the columns on the sheet
'throws an error otherwise as it gets a bit confused by columns being
'missing
'Set the number of columns in the active region
intNumCols = ActiveCell.CurrentRegion.Columns.Count
'Convert the column number to a letter to be able to select the range
strLastCol = ConvertColumnNumberToLetter(intNumCols)
Range("A1:" & strLastCol & "1").Select
Selection.AutoFilter
i = 0
For i = 0 To UBound(arrCriteria)
'first check for an operator
If IsNull(arrFilterOperator(i)) Then
Cells(1, arrCriteria(i)).AutoFilter _
Field:=arrCriteria(i), _
Criteria1:=arrFilter1(i)
Else
'We have an operator so need to add two criteria values
Cells(1, arrCriteria(i)).AutoFilter _
arrCriteria(i), _
Criteria1:=arrFilter1(i), _
Operator:=arrFilterOperator(i), _
Criteria2:=arrFilter2(i)
End If
Next i
Else
'Just take off the filters, delete and re-apply
ActiveSheet.AutoFilterMode = False
strColLett = Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2)
ActiveSheet.Columns(strColLett & ":" & strColLett).Select
Selection.Delete
intNumCols = ActiveCell.CurrentRegion.Columns.Count
strLastCol = ConvertColumnNumberToLetter(intNumCols)
Range("A1:" & strLastCol & "1").Select
Selection.AutoFilter
End If
End Sub
Public Sub Insert_While_Filtered()
Dim rngFilter As Range
Dim arrCriteria
Dim arrFilter1
Dim arrFilter2
Dim arrFilterOperator
Dim strColLett As String
Dim strLastCol As String
Dim i As Integer
Dim x As Integer
Dim c As Integer
Dim a As Integer
Dim intNumCols As Integer
Dim blnCurrentCol As Boolean
Set rngFilter = ActiveCell.CurrentRegion
i = 1
x = 0
'Are filters on?
If ActiveSheet.AutoFilterMode = False Then Exit Sub
'---------------------------------------------------------
'We need to take the insertion point into account later...
'---------------------------------------------------------
c = ActiveCell.Column
'Are any filters applied?
For i = 1 To rngFilter.Worksheet.AutoFilter.Filters.Count
If rngFilter.Worksheet.AutoFilter.Filters(i).On = True Then
x = x + 1
Else
End If
Next i
'Reset the counter for use later
i = 1
'Are filters active?
If x > 0 Then
'------------------------------------------------
'Loop through the filters, appending the criteria
'------------------------------------------------
Do Until i = rngFilter.Worksheet.AutoFilter.Filters.Count + 1
'Is the filter on?
If rngFilter.Worksheet.AutoFilter.Filters(i).On = True Then
'----------------------------------
'Add the column number to the array
'----------------------------------
'-----------------------------------------------------------
'set the column value for the array, because when the column
'is inserted, the columns to the right will increase in
'number by 1
'-----------------------------------------------------------
If i < c Then 'at or before the active column
a = i
Else 'after the active column
a = i + 1
End If
'Check to see if it's first time around
If Not IsArray(arrCriteria) Then
ReDim arrCriteria(0)
arrCriteria(UBound(arrCriteria)) = a
Else
ReDim Preserve arrCriteria(UBound(arrCriteria) + 1)
arrCriteria(UBound(arrCriteria)) = a
End If
'------------------------------------
'Redimension the three criteria arrays
'------------------------------------
'Check to see if it's first time around
If Not IsArray(arrFilter1) Then
'It is, instantiate the array
ReDim arrFilter1(0)
Else
'It's not, just add a new element
ReDim Preserve arrFilter1(UBound(arrFilter1) + 1)
End If
'Ditto
If Not IsArray(arrFilter2) Then
ReDim arrFilter2(0)
Else
ReDim Preserve arrFilter2(UBound(arrFilter2) + 1)
End If
'Ditto
If Not IsArray(arrFilterOperator) Then
ReDim arrFilterOperator(0)
Else
ReDim Preserve arrFilterOperator(UBound(arrFilterOperator) + 1)
End If
'Is there an operator?
If (rngFilter.Worksheet.AutoFilter.Filters(i).Operator = xlOr Or rngFilter.Worksheet.AutoFilter.Filters(i).Operator = xlAnd) Then
'If so, add both criteria values to the array
arrFilterOperator(UBound(arrFilterOperator)) = rngFilter.Worksheet.AutoFilter.Filters(i).Operator
arrFilter1(UBound(arrFilter1)) = rngFilter.Worksheet.AutoFilter.Filters(i).Criteria1
arrFilter2(UBound(arrFilter2)) = rngFilter.Worksheet.AutoFilter.Filters(i).Criteria2
Else
'Just add Criteria1
arrFilterOperator(UBound(arrFilterOperator)) = Null
arrFilter1(UBound(arrFilter1)) = rngFilter.Worksheet.AutoFilter.Filters(i).Criteria1
arrFilter2(UBound(arrFilter2)) = Null
End If
Else
End If
i = i + 1
Loop
'----------------------------------------------------------------------------
'Gone through all of the filters, now take them all off and insert the column
'----------------------------------------------------------------------------
ActiveSheet.AutoFilterMode = False
strColLett = Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2)
ActiveSheet.Columns(strColLett & ":" & strColLett).Insert shift:=xlShiftToRight
'--------------------------------------------------
'Now reapply all of the filters that were on before
'--------------------------------------------------
'first turn the filters back on for all of the columns on the sheet
'throws an error otherwise as it selects only the columns to the right
'of the inserted column if a filter is on one of these columns
'Set the number of columns in the active region
intNumCols = ActiveCell.CurrentRegion.Columns.Count
'Convert the column number to a letter to be able to select the range
strLastCol = ConvertColumnNumberToLetter(intNumCols)
Range("A1:" & strLastCol & "1").Select
Selection.AutoFilter
'Reset the counter
i = 0
'loop until the end of the array
For i = 0 To UBound(arrCriteria)
'first check for an operator
If IsNull(arrFilterOperator(i)) Then
Cells(1, arrCriteria(i)).AutoFilter _
Field:=arrCriteria(i), _
Criteria1:=arrFilter1(i)
Else
'We have an operator so need to add two criteria values
Cells(1, arrCriteria(i)).AutoFilter _
arrCriteria(i), _
Criteria1:=arrFilter1(i), _
Operator:=arrFilterOperator(i), _
Criteria2:=arrFilter2(i)
End If
Next i
Else
'Just take off the filters, insert and re-apply
ActiveSheet.AutoFilterMode = False
strColLett = Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2)
ActiveSheet.Columns(strColLett & ":" & strColLett).Insert shift:=xlShiftToRight
intNumCols = ActiveCell.CurrentRegion.Columns.Count
strLastCol = ConvertColumnNumberToLetter(intNumCols)
Range("A1:" & strLastCol & "1").Select
Selection.AutoFilter
End If
End Sub
Code:
Public Function ConvertColumnNumberToLetter(ByVal ColumnNumber As Integer)
'from [URL unfurl="true"]http://vba-programmer.com/Snippets/Code_Excel/Column_Numbers_to_Letters.html[/URL]
Dim IntegerResult As Integer
Dim FractionalResult As Integer
Dim Remainder As Integer
Dim FirstLetter As String
Dim SecondLetter As String
IntegerResult = ColumnNumber \ 26
FractionalResult = (ColumnNumber / 26) - IntegerResult
Remainder = ColumnNumber Mod 26
If IntegerResult = 0 Then
FirstLetter = ""
ElseIf IntegerResult = 1 And FractionalResult = 0 Then
FirstLetter = ""
ConvertColumnNumberToLetter = "Z"
Exit Function
ElseIf IntegerResult > 1 And FractionalResult = 0 Then
FirstLetter = Chr(64 + (IntegerResult - 1))
ConvertColumnNumberToLetter = FirstLetter & "Z"
Exit Function
Else
FirstLetter = Chr(64 + IntegerResult)
End If
SecondLetter = Chr(64 + Remainder)
ConvertColumnNumberToLetter = FirstLetter & SecondLetter
End Function