Revision: 61529
Updated Code
at February 20, 2013 21:16 by lolrenx
Updated Code
Option Explicit
Option Compare Text
' Models a discrete range (select a cell and press Ctrl+A) as a modifiable data table
Private cRange As Range
Public Event OccuredBlankRow()
Property Set Range(tgtRange As Range)
' Init with either one cell from the range or the whole preset range
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
'return full range - inc headers
Set Range = cRange
End Property
Property Get Range_No_Header() As Range
'return range excluding header (if rowcount >1)
If Me.Range.Rows.Count = 1 Then
Set Range_No_Header = Me.Range
Else
Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
End If
End Property
Property Get RowCount() As Long
'count of rows including header
RowCount = cRange.Rows.Count
End Property
Property Get ColumnsCount() As Long
'count of columns
ColumnsCount = cRange.Columns.Count
End Property
Property Get HeaderString(Separator As String) As String
'apply a 'range to string' to header range with user-defined separator
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
Set tCell = Nothing
tmpString = vbNullString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
'return column without header, or full datarange if no header passed
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = Me.Range_No_Header
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
On Error Resume Next
TempVar = 0
Set TempVar = Nothing
On Error GoTo 0
i = 0
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
If GetColumn.Rows.Count = 1 Then
Exit Property
Else
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End If
End Property
Property Get First_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
Set First_Cell = tRange.Cells(1, 1)
Set tRange = Nothing
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
Set tRange = Nothing
End Property
Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
On Error Resume Next
Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
On Error GoTo 0
If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
Else
Value_Lookup = ""
End If
End Property
Public Sub ClearData(Optional ClearHeaders As Boolean)
Call Me.Remove_Blank_Rows
If ClearHeaders Then
Me.Range.Clear
Else
Me.Range_No_Header.Clear
End If
End Sub
Sub Remove_Multiple_Columns(ColHeaders As Variant)
If IsMissing(ColHeaders) Then Exit Sub
Dim i As Long
If IsArray(ColHeaders) Then
For i = LBound(ColHeaders) To UBound(ColHeaders)
Call Me.Remove_Column(CStr(ColHeaders(i)))
Next i
End If
i = 0
End Sub
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
colNum = 0
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
colNum = 0
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
Erase VrtValues
i = 0
j = 0
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
Set tgtRange = Nothing
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
Call Me.Trim_Values
Dim tgtRange As Range: Set tgtRange = Me.Range
If Not Reverse Then
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
'reset rank to exclude blank rows
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Else
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
End If
Set cRange = tgtRange.Cells(1, 1)
Set tgtRange = Nothing
tgtCol = 0
End Sub
Sub Remove_Blank_Rows(Optional ForceDelete As Boolean)
If Me.Range Is Nothing Or Not Blank_Row_Exists Then Exit Sub
Dim KillRange As Range, tCell As Range
If ForceDelete Then
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
Else
Call Me.Sort(Me.Range.Cells(1, 1), True)
Set cRange = cRange.Cells(1, 1).CurrentRegion
End If
Set tCell = Nothing
Set KillRange = Nothing
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim tRange As Range: Set tRange = Me.Range
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then
KillRange.ClearContents
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
Set KillRange = Nothing
Set Col1 = Nothing
Set Col2 = Nothing
i = 0
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Columns(str As Variant)
'Delete any column whose header is not in str
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
tgtCol = 0
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, _
Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
'use nocalc is several consecutive range to be filled, calc at the end
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
If NoCalc Then ForceValue = False Else FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
LastRow = 0
Set FillRange = Nothing
End Sub
Sub Remove_Duplicates(str As Variant)
Dim tRange As Range: Set tRange = Me.Range
'remove duplicates in str columns - accepts either single string or strings array
If IsArray(str) Then
Dim TempStr() As Variant, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
If TypeName(str(i)) = "String" Then
TempStr(i) = Me.Match_Column(CStr(str(i)))
ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
TempStr(i) = str(i)
End If
Next i
tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
Else
If TypeName(str) = "String" Then
tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
tRange.RemoveDuplicates Columns:=str, Header:=xlYes
End If
End If
Erase TempStr
Call Me.Remove_Blank_Rows
End Sub
Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
'delete cells below 'cap' threshold, option to delete entirerow
If Len(ColHeader) = 0 Then Exit Sub
Dim tgtRange As Range, tCell As Range, KillRange As Range
Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
For Each tCell In tgtRange.Cells
If tCell.Value < Cap Then
If EntireRow Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
Else
Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
End If
End If
Next tCell
If EntireRow Then
If Not KillRange Is Nothing Then KillRange.ClearContents
Else
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End If
Call Me.Remove_Blank_Rows
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
'true if value exists in specified range or array
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Private Function Blank_Row_Exists() As Boolean
'scan upwards from last row looking for empty rows, true if found
Blank_Row_Exists = False
Dim tRange As Range: Set tRange = Me.Range
Dim i As Long
For i = tRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
Blank_Row_Exists = True
Exit For
End If
Next i
Set tRange = Nothing
End Function
Revision: 61528
Updated Code
at February 7, 2013 21:49 by lolrenx
Updated Code
Option Explicit
' Models a discrete range (select a cell and press Ctrl+A) as a modifiable data table
Private cRange As Range
Public Event OccuredBlankRow()
Property Set Range(tgtRange As Range)
' Init with either one cell from the range or the whole preset range
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
'return full range - inc headers
Set Range = cRange
End Property
Property Get Range_No_Header() As Range
'return range excluding header (if rowcount >1)
If Me.Range.Rows.Count = 1 Then
Set Range_No_Header = Me.Range
Else
Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
End If
End Property
Property Get RowCount() As Long
'count of rows including header
RowCount = cRange.Rows.Count
End Property
Property Get ColumnsCount() As Long
'count of columns
ColumnsCount = cRange.Columns.Count
End Property
Property Get HeaderString(Separator As String) As String
'apply a 'range to string' to header range with user-defined separator
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
Set tCell = Nothing
tmpString = vbNullString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
'return column without header, or full datarange if no header passed
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = Me.Range_No_Header
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
On Error Resume Next
TempVar = 0
Set TempVar = Nothing
On Error GoTo 0
i = 0
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
If GetColumn.Rows.Count = 1 Then
Exit Property
Else
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End If
End Property
Property Get First_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
Set First_Cell = tRange.Cells(1, 1)
Set tRange = Nothing
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
Set tRange = Nothing
End Property
Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
On Error Resume Next
Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
On Error GoTo 0
If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
Else
Value_Lookup = ""
End If
End Property
Public Sub ClearData(Optional ClearHeaders As Boolean)
Call Me.Remove_Blank_Rows
If ClearHeaders Then
Me.Range.Clear
Else
Me.Range_No_Header.Clear
End If
End Sub
Sub Remove_Multiple_Columns(ColHeaders As Variant)
If IsMissing(ColHeaders) Then Exit Sub
Dim i As Long
If IsArray(ColHeaders) Then
For i = LBound(ColHeaders) To UBound(ColHeaders)
Call Me.Remove_Column(CStr(ColHeaders(i)))
Next i
End If
i = 0
End Sub
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
colNum = 0
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
colNum = 0
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
Erase VrtValues
i = 0
j = 0
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
Set tgtRange = Nothing
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
Call Me.Trim_Values
Dim tgtRange As Range: Set tgtRange = Me.Range
If Not Reverse Then
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
'reset rank to exclude blank rows
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Else
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
End If
Set cRange = tgtRange.Cells(1, 1)
Set tgtRange = Nothing
tgtCol = 0
End Sub
Sub Remove_Blank_Rows(Optional ForceDelete As Boolean)
If Me.Range Is Nothing Or Not Blank_Row_Exists Then Exit Sub
Dim KillRange As Range, tCell As Range
If ForceDelete Then
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
Else
Call Me.Sort(Me.Range.Cells(1, 1), True)
Set cRange = cRange.Cells(1, 1).CurrentRegion
End If
Set tCell = Nothing
Set KillRange = Nothing
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim tRange As Range: Set tRange = Me.Range
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then
KillRange.ClearContents
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
Set KillRange = Nothing
Set Col1 = Nothing
Set Col2 = Nothing
i = 0
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Columns(str As Variant)
'Delete any column whose header is not in str
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
tgtCol = 0
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, _
Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
'use nocalc is several consecutive range to be filled, calc at the end
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
If NoCalc Then ForceValue = False Else FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
LastRow = 0
Set FillRange = Nothing
End Sub
Sub Remove_Duplicates(str As Variant)
Dim tRange As Range: Set tRange = Me.Range
If IsArray(str) Then
Dim TempStr() As Variant, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
If TypeName(str(i)) = "String" Then
TempStr(i) = Me.Match_Column(CStr(str(i)))
ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
TempStr(i) = str(i)
End If
Next i
tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
Else
If TypeName(str) = "String" Then
tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
tRange.RemoveDuplicates Columns:=str, Header:=xlYes
End If
End If
Erase TempStr
Call Me.Remove_Blank_Rows
End Sub
Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
If Len(ColHeader) = 0 Then Exit Sub
Dim tgtRange As Range, tCell As Range, KillRange As Range
Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
For Each tCell In tgtRange.Cells
If tCell.Value < Cap Then
If EntireRow Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
Else
Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
End If
End If
Next tCell
If EntireRow Then
If Not KillRange Is Nothing Then KillRange.ClearContents
Else
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End If
Call Me.Remove_Blank_Rows
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Private Function Blank_Row_Exists() As Boolean
Blank_Row_Exists = False
Dim tRange As Range: Set tRange = Me.Range
Dim i As Long
For i = tRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
Blank_Row_Exists = True
Exit For
End If
Next i
Set tRange = Nothing
End Function
Revision: 61527
Updated Code
at January 24, 2013 03:47 by lolrenx
Updated Code
Option Explicit
' Models a discrete range (select a cell and press Ctrl+A) as a modifiable data table
' Init with either one cell from the range or the whole preset range
Private cRange As Range
Public Event OccuredBlankRow()
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get Range_No_Header() As Range
If Me.Range.Rows.Count = 1 Then
Set Range_No_Header = Me.Range
Else
Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
End If
End Property
Property Get RowCount() As Long
RowCount = cRange.Rows.Count
End Property
Property Get ColCount() As Long
ColCount = cRange.Columns.Count
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
Set tCell = Nothing
tmpString = vbNullString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
On Error Resume Next
TempVar = 0
Set TempVar = Nothing
On Error GoTo 0
i = 0
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
If GetColumn.Rows.Count = 1 Then
Exit Property
Else
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End If
End Property
Property Get First_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
Set First_Cell = tRange.Cells(1, 1)
Set tRange = Nothing
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
Set tRange = Nothing
End Property
Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
On Error Resume Next
Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
On Error GoTo 0
If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
Else
Value_Lookup = ""
End If
End Property
Public Sub ClearData(Optional ClearHeaders As Boolean)
Call Me.Remove_Blank_Rows
If ClearHeaders Then
Me.Range.Clear
Else
Me.Range_No_Header.Clear
End If
End Sub
Sub Remove_Multiple_Columns(ColHeaders As Variant)
If IsMissing(ColHeaders) Then Exit Sub
Dim i As Long
If IsArray(ColHeaders) Then
For i = LBound(ColHeaders) To UBound(ColHeaders)
Call Me.Remove_Column(CStr(ColHeaders(i)))
Next i
End If
i = 0
End Sub
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
colNum = 0
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
colNum = 0
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
Erase VrtValues
i = 0
j = 0
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
Set tgtRange = Nothing
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
Call Me.Trim_Values
Dim tgtRange As Range: Set tgtRange = Me.Range
If Not Reverse Then
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
'reset rank to exclude blank rows
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Else
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
End If
Set cRange = tgtRange.Cells(1, 1)
Set tgtRange = Nothing
tgtCol = 0
End Sub
Sub Remove_Blank_Rows(Optional ForceDelete As Boolean)
If Me.Range Is Nothing Or Not Blank_Row_Exists Then Exit Sub
Dim KillRange As Range, tCell As Range
If ForceDelete Then
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
Else
Call Me.Sort(Me.Range.Cells(1, 1), True)
Set cRange = cRange.Cells(1, 1).CurrentRegion
End If
Set tCell = Nothing
Set KillRange = Nothing
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim tRange As Range: Set tRange = Me.Range
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then
KillRange.ClearContents
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
Set KillRange = Nothing
Set Col1 = Nothing
Set Col2 = Nothing
i = 0
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Columns(str As Variant)
'Delete any column whose header is not in str
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
tgtCol = 0
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, _
Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
'use nocalc is several consecutive range to be filled, calc at the end
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
If NoCalc Then ForceValue = False Else FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
LastRow = 0
Set FillRange = Nothing
End Sub
Sub Remove_Duplicates(str As Variant)
Dim tRange As Range: Set tRange = Me.Range
If IsArray(str) Then
Dim TempStr() As Variant, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
If TypeName(str(i)) = "String" Then
TempStr(i) = Me.Match_Column(CStr(str(i)))
ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
TempStr(i) = str(i)
End If
Next i
tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
Else
If TypeName(str) = "String" Then
tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
tRange.RemoveDuplicates Columns:=str, Header:=xlYes
End If
End If
Erase TempStr
Call Me.Remove_Blank_Rows
End Sub
Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
If Len(ColHeader) = 0 Then Exit Sub
Dim tgtRange As Range, tCell As Range, KillRange As Range
Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
For Each tCell In tgtRange.Cells
If tCell.Value < Cap Then
If EntireRow Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
Else
Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
End If
End If
Next tCell
If EntireRow Then
If Not KillRange Is Nothing Then KillRange.ClearContents
Else
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End If
Call Me.Remove_Blank_Rows
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Private Function Blank_Row_Exists() As Boolean
Blank_Row_Exists = False
Dim tRange As Range: Set tRange = Me.Range
Dim i As Long
For i = tRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
Blank_Row_Exists = True
Exit For
End If
Next i
Set tRange = Nothing
End Function
Revision: 61526
Updated Code
at January 12, 2013 00:08 by lolrenx
Updated Code
Option Explicit
' Models a discrete range (select a cell and press Ctrl+A) as a modifiable data table
' Init with either one cell from the range or the whole preset range
Private cRange As Range
Public Event OccuredBlankRow()
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get Range_No_Header() As Range
If Me.Range.Rows.Count = 1 Then
Set Range_No_Header = Me.Range
Else
Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
End If
End Property
Property Get RowCount() As Long
RowCount = cRange.Rows.Count
End Property
Property Get ColCount() As Long
ColCount = cRange.Columns.Count
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
Set tCell = Nothing
tmpString = vbNullString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
On Error Resume Next
TempVar = 0
Set TempVar = Nothing
On Error GoTo 0
i = 0
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
If GetColumn.Rows.Count = 1 Then
Exit Property
Else
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End If
End Property
Property Get First_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
Set First_Cell = tRange.Cells(1, 1)
Set tRange = Nothing
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
Set tRange = Nothing
End Property
Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
On Error Resume Next
Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
On Error GoTo 0
If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
Else
Value_Lookup = ""
End If
End Property
Public Sub ClearData(Optional ClearHeaders As Boolean)
Call Me.Remove_Blank_Rows
If ClearHeaders Then
Me.Range.Clear
Else
Me.Range_No_Header.Clear
End If
End Sub
Sub Remove_Multiple_Columns(ColHeaders As Variant)
If IsMissing(ColHeaders) Then Exit Sub
Dim i As Long
If IsArray(ColHeaders) Then
For i = LBound(ColHeaders) To UBound(ColHeaders)
Call Me.Remove_Column(CStr(ColHeaders(i)))
Next i
End If
i = 0
End Sub
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
colNum = 0
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
colNum = 0
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
Erase VrtValues
i = 0
j = 0
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
Set tgtRange = Nothing
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
Call Me.Trim_Values
Dim tgtRange As Range: Set tgtRange = Me.Range
If Not Reverse Then
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
'reset rank to exclude blank rows
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Else
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
End If
Set cRange = tgtRange.Cells(1, 1)
Set tgtRange = Nothing
tgtCol = 0
End Sub
Sub Remove_Blank_Rows(Optional ForceDelete As Boolean)
If Me.Range Is Nothing Or Not Blank_Row_Exists Then Exit Sub
Dim KillRange As Range, tCell As Range
If ForceDelete Then
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
Else
Call Me.Sort(Me.Range.Cells(1, 1), True)
Set cRange = cRange.Cells(1, 1).CurrentRegion
End If
Set tCell = Nothing
Set KillRange = Nothing
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim tRange As Range: Set tRange = Me.Range
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then
KillRange.ClearContents
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
Set KillRange = Nothing
Set Col1 = Nothing
Set Col2 = Nothing
i = 0
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Columns(str As Variant)
'Delete any column whose header is not in str
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
tgtCol = 0
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, _
Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
'use nocalc is several consecutive range to be filled, calc at the end
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
If NoCalc Then ForceValue = False Else FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
LastRow = 0
Set FillRange = Nothing
End Sub
Sub Remove_Duplicates(str As Variant)
Dim tRange As Range: Set tRange = Me.Range
If IsArray(str) Then
Dim TempStr() As Variant, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
If TypeName(str(i)) = "String" Then
TempStr(i) = Me.Match_Column(CStr(str(i)))
ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
TempStr(i) = str(i)
End If
Next i
tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
Else
If TypeName(str) = "String" Then
tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
tRange.RemoveDuplicates Columns:=str, Header:=xlYes
End If
End If
Erase TempStr
Call Me.Remove_Blank_Rows
End Sub
Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
If Len(ColHeader) = 0 Then Exit Sub
Dim tgtRange As Range, tCell As Range, KillRange As Range
Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
For Each tCell In tgtRange.Cells
If tCell.Value < Cap Then
If EntireRow Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
Else
Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
End If
End If
Next tCell
If EntireRow Then
If Not KillRange Is Nothing Then KillRange.ClearContents
Else
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End If
Call Me.Remove_Blank_Rows
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Private Function Blank_Row_Exists() As Boolean
Blank_Row_Exists = False
Dim tRange As Range: Set tRange = Me.Range
Dim i As Long
For i = tRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
Blank_Row_Exists = True
Exit For
End If
Next i
Set tRange = Nothing
End Function
Revision: 61525
Updated Code
at January 11, 2013 03:31 by lolrenx
Updated Code
Option Explicit
' Models a discrete range (select a cell and press Ctrl+A) as a modifiable data table
' Init with either one cell from the range or the whole preset range
Private cRange As Range
Public Event OccuredBlankRow()
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get Range_No_Header() As Range
If Me.Range.Rows.Count = 1 Then
Set Range_No_Header = Me.Range
Else
Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
End If
End Property
Property Get RowCount() As Long
RowCount = cRange.Rows.Count
End Property
Property Get ColCount() As Long
ColCount = cRange.Columns.Count
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
Set tCell = Nothing
tmpString = vbNullString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
On Error Resume Next
TempVar = 0
Set TempVar = Nothing
On Error GoTo 0
i = 0
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
If GetColumn.Rows.Count = 1 Then
Exit Property
Else
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End If
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
Set tRange = Nothing
End Property
Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
On Error Resume Next
Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
On Error GoTo 0
If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
Else
Value_Lookup = ""
End If
End Property
Public Sub ClearData(Optional ClearHeaders As Boolean)
Call Me.Remove_Blank_Rows
If ClearHeaders Then
Me.Range.Clear
Else
Me.Range_No_Header.Clear
End If
End Sub
Sub Remove_Multiple_Columns(ColHeaders As Variant)
If IsMissing(ColHeaders) Then Exit Sub
Dim i As Long
If IsArray(ColHeaders) Then
For i = LBound(ColHeaders) To UBound(ColHeaders)
Call Me.Remove_Column(CStr(ColHeaders(i)))
Next i
End If
i = 0
End Sub
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
colNum = 0
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
colNum = 0
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
Erase VrtValues
i = 0
j = 0
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
Set tgtRange = Nothing
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
With Me.Range.Parent.Sort
.SortFields.Clear
If Reverse Then
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
Else
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End If
.SetRange Me.Range
If ForceHeader Then
.Header = xlYes
Else
.Header = xlGuess
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
tgtCol = 0
End Sub
Sub Remove_Blank_Rows(Optional ForceDelete As Boolean)
If Me.Range Is Nothing Then Exit Sub
Dim KillRange As Range, tCell As Range
If ForceDelete Then
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
Else
Call Me.Sort(Me.Range.Cells(1, 1), True)
Set cRange = cRange.Cells(1, 1).CurrentRegion
End If
Set tCell = Nothing
Set KillRange = Nothing
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim tRange As Range: Set tRange = Me.Range
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then
KillRange.ClearContents
If Blank_Row_Exists Then Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
Set KillRange = Nothing
Set Col1 = Nothing
Set Col2 = Nothing
i = 0
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Columns(str As Variant)
'Delete any column whose header is not in str
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
If Blank_Row_Exists Then Call Me.Remove_Blank_Rows
End If
Set tRange = Nothing
tgtCol = 0
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, _
Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
'use nocalc is several consecutive range to be filled, calc at the end
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
If NoCalc Then ForceValue = False Else FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
LastRow = 0
Set FillRange = Nothing
End Sub
Sub Remove_Duplicates(str As Variant)
Dim tRange As Range: Set tRange = Me.Range
If IsArray(str) Then
Dim TempStr() As Variant, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
If TypeName(str(i)) = "String" Then
TempStr(i) = Me.Match_Column(CStr(str(i)))
ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
TempStr(i) = str(i)
End If
Next i
tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
Else
If TypeName(str) = "String" Then
tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
tRange.RemoveDuplicates Columns:=str, Header:=xlGuess
End If
End If
Erase TempStr
If Blank_Row_Exists Then Call Me.Remove_Blank_Rows
End Sub
Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
If Len(ColHeader) = 0 Then Exit Sub
Dim tgtRange As Range, tCell As Range, KillRange As Range
Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
For Each tCell In tgtRange.Cells
If tCell.Value < Cap Then
If EntireRow Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
Else
Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
End If
End If
Next tCell
If EntireRow Then
If Not KillRange Is Nothing Then KillRange.ClearContents
Else
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End If
If Blank_Row_Exists Then Call Me.Remove_Blank_Rows
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Private Function Blank_Row_Exists() As Boolean
Blank_Row_Exists = False
Dim tRange As Range: Set tRange = Me.Range
Dim i As Long
For i = tRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
Blank_Row_Exists = True
Exit For
End If
Next i
Set tRange = Nothing
End Function
Revision: 61524
Updated Code
at January 11, 2013 00:59 by lolrenx
Updated Code
Option Explicit
Private cRange As Range
Public Event OccuredBlankRow()
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get Range_No_Header() As Range
If Me.Range.Rows.Count = 1 Then
Set Range_No_Header = Me.Range
Else
Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
End If
End Property
Property Get RowCount() As Long
RowCount = cRange.Rows.Count
End Property
Property Get ColCount() As Long
ColCount = cRange.Columns.Count
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
Set tCell = Nothing
tmpString = vbNullString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
On Error Resume Next
TempVar = 0
Set TempVar = Nothing
On Error GoTo 0
i = 0
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
If GetColumn.Rows.Count = 1 Then
Exit Property
Else
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End If
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
Set tRange = Nothing
End Property
Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
Dim tgtRange As Range: Set tgtRange = Me.Range
On Error Resume Next
Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
On Error GoTo 0
If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
Else
Value_Lookup = ""
End If
End Property
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
colNum = 0
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
colNum = 0
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
Erase VrtValues
i = 0
j = 0
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
Set tgtRange = Nothing
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
With Me.Range.Parent.Sort
.SortFields.Clear
If Reverse Then
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
Else
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End If
.SetRange Me.Range
If ForceHeader Then
.Header = xlYes
Else
.Header = xlGuess
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
tgtCol = 0
End Sub
Sub Remove_Blank_Rows()
If Me.Range Is Nothing Then Exit Sub
Dim KillRange As Range, tCell As Range
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
Set tCell = Nothing
Set KillRange = Nothing
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim tRange As Range: Set tRange = Me.Range
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then
KillRange.ClearContents
If Blank_Row_Exists Then
Call Me.Sort(CStr(tRange.Cells(1, 1)), True)
Set cRange = tRange.CurrentRegion
End If
End If
Set tRange = Nothing
Set KillRange = Nothing
Set Col1 = Nothing
Set Col2 = Nothing
i = 0
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
Set KillRange = Nothing
Set SearchRange = Nothing
Set tCell = Nothing
Set tgtRange = Nothing
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
Set KillRange = Nothing
Set SearchRange = Nothing
Set vrtSearch = Nothing
Set tgtRange = Nothing
i = 0
j = 0
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
If Blank_Row_Exists Then
Call Me.Sort(CStr(tRange.Cells(1, 1)), True)
Set cRange = tRange.CurrentRegion
End If
End If
Set tRange = Nothing
tgtCol = 0
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, _
Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
'use nocalc is several consecutive range to be filled, calc at the end
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
If NoCalc Then ForceValue = False Else FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
LastRow = 0
Set FillRange = Nothing
End Sub
Sub Remove_Duplicates(str As Variant)
Dim tRange As Range: Set tRange = Me.Range
If IsArray(str) Then
Dim TempStr() As Variant, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
If TypeName(str(i)) = "String" Then
TempStr(i) = Me.Match_Column(CStr(str(i)))
ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
TempStr(i) = str(i)
End If
Next i
tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
Else
If TypeName(str) = "String" Then
tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
tRange.RemoveDuplicates Columns:=str, Header:=xlGuess
End If
End If
Erase TempStr
If Blank_Row_Exists Then
Call Me.Sort(CStr(tRange.Cells(1, 1)), True)
Set cRange = tRange.CurrentRegion
End If
End Sub
Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
If Len(ColHeader) = 0 Then Exit Sub
Dim tgtRange As Range, tCell As Range, KillRange As Range
Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
For Each tCell In tgtRange.Cells
If tCell.Value < Cap Then
If EntireRow Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
Else
Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
End If
End If
Next tCell
If EntireRow Then
If Not KillRange Is Nothing Then KillRange.ClearContents
Else
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End If
If Blank_Row_Exists Then
Call Me.Sort(CStr(Me.Range.Cells(1, 1)), True)
Set cRange = Me.Range.CurrentRegion
End If
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Private Function Blank_Row_Exists() As Boolean
Blank_Row_Exists = False
Dim tRange As Range: Set tRange = Me.Range
Dim i As Long
For i = tRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
Blank_Row_Exists = True
Exit For
End If
Next i
Set tRange = Nothing
End Function
Revision: 61523
Updated Code
at January 8, 2013 20:13 by lolrenx
Updated Code
Option Explicit
Private cRange As Range
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
End Property
Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If OmitHeader And Not GetColumn Is Nothing Then
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End Property
Property Get Last_Cell() As Range
Dim tRange As Range: Set tRange = Me.Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End With
End Property
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Apply_Color(ColHeader As String, xColor As Long)
Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
If tgtRange Is Nothing Then Exit Sub
tgtRange.Interior.Color = xColor
End Sub
Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean)
If Len(SortingColumnHeader) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
With Me.Range.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Me.Range
If ForceHeader Then
.Header = xlYes
Else
.Header = xlGuess
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Remove_Blank_Rows()
If Me.Range Is Nothing Then Exit Sub
Dim KillRange As Range, tCell As Range
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
End Sub
Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
End Sub
Sub Keep_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
End Sub
Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
Optional ForceNoResort As Boolean)
'faster for bigger datasets than delete rows
If ColHeader = vbNullString Then Exit Sub
Dim tRange As Range: Set tRange = Me.Range
Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
tRange.Rows(1).EntireRow.Hidden = True
On Error Resume Next
tRange.AutoFilter = False
tRange.AutoFilter
On Error GoTo 0
tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
On Error Resume Next
tRange.SpecialCells(xlVisible).EntireRow.ClearContents
tRange.AutoFilter = False
tRange.Parent.ShowAllData
On Error GoTo 0
tRange.Rows(1).EntireRow.Hidden = False
If Not ForceNoResort Then
Call Me.Sort(CStr(tRange.Cells(1, 1)), True)
Set cRange = tRange.CurrentRegion
End If
End Sub
Sub Expand_Formula(ColHeader As String, FormulaString As String, Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean)
If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
Dim LastRow As Long: LastRow = Me.Last_Cell.Row
Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
If FillRange Is Nothing Then Exit Sub
If IsArrayFormula Then
FillRange.Cells(1).FormulaArray = FormulaString
Else
FillRange.Cells(1).Formula = FormulaString
End If
FillRange.Cells(1).AutoFill Destination:=FillRange
FillRange.Calculate
If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
End Sub
Sub Remove_Duplicates(str As Variant)
If IsArray(str) Then
Dim TempStr() As Long, i As Long
ReDim TempStr(0 To UBound(str))
For i = 0 To UBound(TempStr)
TempStr(i) = Me.Match_Column(CStr(str(i)))
Next i
Me.Range.RemoveDuplicates Columns:=TempStr, Header:=xlYes
Else
Me.Range.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlYes
End If
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Revision: 61522
Updated Code
at January 5, 2013 04:31 by lolrenx
Updated Code
Option Explicit
Private cRange As Range
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
End Property
Property Get GetColumn(Header As String, Optional noHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If noHeader And Not GetColumn Is Nothing Then
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End Property
Property Get Last_Cell() As Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or .Cells.Count = 1 Then
Set Last_Cell = .Cells(1, 1)
Else
Set Last_Cell = .Cells(.Rows.Count, .Columns.Count)
End If
End With
End Property
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Sort(SortingColumn As String)
If Len(SortingColumn) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumn, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
With Me.Range.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Me.Range
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Remove_Blank_Rows()
If Me.Range Is Nothing Then Exit Sub
Dim KillRange As Range, tCell As Range
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
End Sub
Public Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End Sub
Sub Delete_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
End Sub
Sub Keep_Columns(str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, tCell As Range
Set SearchRange = Me.HeaderRange
If SearchRange Is Nothing Then Exit Sub
For Each tCell In SearchRange.Cells
If Not Value_Exists_in_Range(tCell.Value, str, True) Then
Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
End If
Next tCell
If Not KillRange Is Nothing Then KillRange.Delete
End Sub
Sub Keep_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
End Sub
Sub Delete_Row_Value(ColHeader As String, str As Variant)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
If IsArray(tgtRange) Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
GoTo SingleCheckValue
End If
ElseIf TypeName(tgtRange) = "Range" Then
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
Else
SingleCheckValue:
If CStr(tgtRange) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
End If
End Function
Revision: 61521
Updated Code
at January 5, 2013 03:27 by lolrenx
Updated Code
Option Explicit
Private cRange As Range
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get Match_Column(tString As String) As Long
'returns absolute reference to search for a header, works for data in col as well
If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = tString
i = i + 1
Loop
End If
If i > 0 Then
Match_Column = i
End If
End Property
Property Get GetColumn(Header As String, Optional noHeader As Boolean) As Range
If Me.Match_Column(Header) = 0 Then Exit Property
Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
If noHeader And Not GetColumn Is Nothing Then
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End Property
Property Get Last_Cell() As Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or .Cells.Count = 1 Then
Set Last_Cell = .Cells(1, 1)
Else
Set Last_Cell = .Cells(.Rows.Count, .Columns.Count)
End If
End With
End Property
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
.Value = .Value
If RemoveNumberFormat Then .NumberFormat = "General"
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Sort(SortingColumn As String)
If Len(SortingColumn) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumn, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
With Me.Range.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Me.Range
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Remove_Blank_Rows()
If Me.Range Is Nothing Then Exit Sub
Dim KillRange As Range, tCell As Range
For Each tCell In Me.Range.Columns(1).Cells
If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
If KillRange Is Nothing Then
Set KillRange = Intersect(tCell.EntireRow, Me.Range)
Else
Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
End If
End If
Next tCell
If Not KillRange Is Nothing Then
KillRange.Delete xlUp
End If
End Sub
Public Sub Delete_if_Different(Header1 As String, Header2 As String, _
Optional DeleteIfSame As Boolean)
'compares cells in 2 col on the same row, if cells are different then delete row
'optional if cells are same, delete row
Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
Dim i As Long, KillRange As Range
For i = 1 To Col1.Cells.Count
If DeleteIfSame Then
If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
Else
If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
End Sub
Sub Keep_Row_Value(ColHeader As String, str() As String)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
'Dim VrtValues As Variant: VrtValues = str
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
End Sub
Public Sub Delete_Row_Value(ColHeader As String, str() As String)
Dim tgtRange As Range: Set tgtRange = Me.Range
If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
Dim KillRange As Range, SearchRange As Range, colNum As Long
Set SearchRange = Me.GetColumn(ColHeader, True)
If SearchRange Is Nothing Then Exit Sub
Call Me.Trim_Values
Dim i As Long, j As Long, vrtSearch As Variant
vrtSearch = SearchRange
For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
End If
Next i
If Not KillRange Is Nothing Then KillRange.Delete xlUp
Application.StatusBar = False
End Sub
Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
Value_Exists_in_Range = False
If Len(SearchValue) = 0 Then Exit Function
If forVariant Then
Dim i As Long
For i = LBound(tgtRange) To UBound(tgtRange)
If CStr(tgtRange(i)) = SearchValue Then
Value_Exists_in_Range = True
Exit Function
End If
Next i
Else
If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
End If
End Function
Revision: 61520
Updated Code
at December 21, 2012 22:44 by lolrenx
Updated Code
Option Explicit
Private cRange As Range
Property Set Range(tgtRange As Range)
If tgtRange Is Nothing Then Exit Property
If tgtRange.Cells.Count = 1 Then
Set cRange = tgtRange.CurrentRegion
Else
Set cRange = tgtRange
End If
End Property
Property Get Range() As Range
Set Range = cRange
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In Me.HeaderRange.Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
End Property
Property Get HeaderRange() As Range
If Me.Range Is Nothing Then Exit Property
Set HeaderRange = Me.Range.Rows(1)
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get GetColumn(Header As String, Optional noHeader As Boolean) As Range
If cRange Is Nothing Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(Header, Me.HeaderRange)
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until Me.HeaderRange.Cells(i) = Header
i = i + 1
Loop
End If
If i > 0 Then
Set GetColumn = cRange.Columns(i)
End If
If noHeader And Not GetColumn Is Nothing Then
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End Property
Property Get Last_Cell() As Range
With Me.Range
If WorksheetFunction.CountA(Me.Range) = 0 Or .Cells.Count = 1 Then
Set Last_Cell = .Cells(1, 1)
Else
Set Last_Cell = .Cells(.Rows.Count, .Columns.Count)
End If
End With
End Property
Sub Remove_Column(ColHeader As String)
If Len(ColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(ColHeader, .Rows(1))
If colNum <> 0 Then .Columns(colNum).Delete
End With
End Sub
Sub Add_Column(AfterColHeader As String, NewHeader As String)
If Len(AfterColHeader) = 0 Then Exit Sub
Dim colNum As Long
With Me.Range
colNum = MatchCol(AfterColHeader, .Rows(1))
If colNum <> 0 Then
.Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(1, colNum + 1) = NewHeader
End If
End With
End Sub
Sub Trim_Values()
If Me.Range Is Nothing Then Exit Sub
Dim VrtValues As Variant: VrtValues = Me.Range.Value
Dim i As Long, j As Long
For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
VrtValues(i, j) = Trim(VrtValues(i, j))
Next j
Next i
Me.Range.Value = VrtValues
End Sub
Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
With Me.Range.Cells
If RemoveNumberFormat Then .NumberFormat = "General"
.Value = .Value
End With
End Sub
Sub Format(Optional NoFill As Boolean, _
Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
If Me.Range Is Nothing Then Exit Sub
If Me.OmitHeader Is Nothing Then GoTo SingleRow
With Me.OmitHeader
.Interior.Pattern = xlPatternNone
.Interior.ThemeColor = xlThemeColorDark1
'If Not NoFill Then .Interior.ColorIndex = 15
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
SingleRow:
If Me.HeaderRange Is Nothing Then Exit Sub
With Me.HeaderRange
If Not NoFill Then .Interior.ColorIndex = 15
.Interior.ColorIndex = 15
If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
End With
End Sub
Sub Sort(SortingColumn As String)
If Len(SortingColumn) = 0 Then Exit Sub
Dim tgtCol As Long: tgtCol = MatchCol(SortingColumn, Me.HeaderRange)
If tgtCol = 0 Then Exit Sub
With Me.Range.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=Me.Range.Columns(tgtCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Me.Range
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Function MatchCol(tString As String, srchRange As Range) As Long
'returns absolute reference to search for a header, works for data in col as well
Dim i As Variant
On Error Resume Next
i = Application.Match(tString, srchRange, 0)
On Error GoTo 0
If Not IsError(i) And TypeName(i) = "Double" Then _
MatchCol = CLng(i)
End Function
Revision: 61519
Initial Code
Initial URL
Initial Description
Initial Title
Initial Tags
Initial Language
at December 20, 2012 02:53 by lolrenx
Initial Code
Option Explicit
Private cRange As Range
Property Set Range(tgtRange As Range)
If Not tgtRange Is Nothing Then
Set cRange = tgtRange
End If
End Propertyclass definition in visual basicclass definition in visual basic
Property Get Range() As Range
Set Range = cRange
End Property
Property Get HeaderString(Separator As String) As String
Dim tCell As Range, tmpString As String
For Each tCell In cRange.Rows(1).Cells
tmpString = tmpString & Separator & Trim(tCell.Value)
Next tCell
Do Until Right(tmpString, 1) <> Separator
tmpString = Left(tmpString, Len(tmpString) - 1)
Loop
Do Until Left(tmpString, 1) <> Separator
tmpString = Right(tmpString, Len(tmpString) - 1)
Loop
HeaderString = tmpString
End Property
Property Get OmitHeader(Optional ColumnHeader As String) As Range
If cRange Is Nothing Then Exit Property
If Len(ColumnHeader) = 0 Then
With cRange
Set OmitHeader = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
End With
Else
Set OmitHeader = Me.GetColumn(ColumnHeader, True)
End If
End Property
Property Get GetColumn(Header As String, Optional noHeader As Boolean) As Range
If cRange Is Nothing Then Exit Property
Dim i As Long
Dim TempVar As Variant
On Error Resume Next
TempVar = WorksheetFunction.Match(Header, cRange.Rows(1))
On Error GoTo 0
If TempVar > 0 Then
i = 1
Do Until cRange.Rows(1).Cells(i) = Header
i = i + 1
Loop
End If
If i > 0 Then
Set GetColumn = cRange.Columns(i)
End If
If noHeader And Not GetColumn Is Nothing Then
Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
End If
End Property
Property Get Last_Cell() As Range
If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
Set Last_Cell = Me.Range.Cells(1, 1)
Else
Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
End If
End Property
Initial URL
Initial Description
consider currentregion as a 'datarange' custom class
Initial Title
Datarange as Class
Initial Tags
class, excel
Initial Language
Visual Basic