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