Posted By

lolrenx on 12/20/12

Tagged

class
excel

Versions (?)

Last Edited at 12/20/12 02:53am

Statistics

Viewed 660 times

Favorited by 1 user(s)

Related snippets

Datarange as Class

/ Published in: Visual Basic

consider currentregion as a 'datarange' custom class

Highlighted TextExpand

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

Report this snippet Tweet

Comments

Subscribe to comments

Comment:

You need to login to post a comment.

Posted By

Tagged

Versions (?)

Statistics

Related snippets

Datarange as Class

Comments

Choose a language for easy browsing: