Snippets Archives - Option Explicit

ReturnName

Function ReturnName(ByVal num As Integer) As String
ReturnName = Split(Cells(, num).Address, "$")(1)
End Function

DeleteInitialColumnsFromWorksheet

Note: This function depends on ReturnName

Sub DeleteInitialColumnsFromWorksheet( _
    ws As Worksheet, _
    NumberOfColumns As Integer _
)
    With ws
        .Columns( _
            ReturnName( _
                1 _
            ) & _
            ":" & _
            ReturnName( _
                NumberOfColumns _
            ) _
        ).Delete _
            Shift:=xlToLeft
    End With
End Sub

GetFilePath

Public Function GetFileNameFromFullPath( _
    sFullFileNameWithPath As String _
) As String
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    GetFileNameFromFullPath = _
        fs.GetFilename( _
            sFullFileNameWithPath _
        )
End Function

GetFileNameFromFullPath

Public Function GetFileNameFromFullPath( _
    sFullFileNameWithPath As String _
) as String
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    GetFileNameFromFullPath = _
        fs.GetFilename( _
            sFullFileNameWithPath _
        )
    Set fs = Nothing
End Function

GetBaseName

Public Function GetBaseName( _
    sFullFileNameWithExtension As String _
)
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    GetBaseName = _
        fs.GetBaseName( _
            sFullFileNameWithExtension _
        )
    Set fs = Nothing
End Function

TransferFontProperties

Public Sub TransferFontProperties( _
    rngSource As Range, _
    rngTarget As Range _
)
    Dim sf As Font
    Set sf = rngSource.Font
    With rngTarget.Font
        .Name = sf.Name
        .Size = sf.Size
        .Strikethrough = sf.Strikethrough
        .Superscript = sf.Superscript
        .Underline = sf.Underline
        .Color = sf.Color
        .Italic = sf.Italic
        .TintAndShade = sf.TintAndShade
        .Subscript = sf.Subscript
        .Bold = sf.Bold
    End With
End Sub

TrimRange

Public Function TrimRange( _
    rngSource As Range, _
    Optional TrimTop As Integer = 0, _
    Optional TrimBottom As Integer = 0, _
    Optional TrimLeft As Integer = 0, _
    Optional TrimRight As Integer = 0 _
) As Range
    Set TrimRange = _
        rngSource.Offset( _
            rowoffset:=TrimTop, _
            columnoffset:=TrimLeft _
        ).Resize( _
            rngSource.Rows.Count - TrimTop - TrimBottom, _
            rngSource.Columns.Count - TrimLeft - TrimRight _
        )
End Function

VBComponentNameIsUnique

Public Function VBComponentNameIsUnique( _
    wb As Workbook, _
    strInputName As String _
) As Boolean
    Dim vbc As VBComponent
    VBComponentNameIsUnique = True
    For Each vbc In wb.VBProject.VBComponents
        If vbc.Name = strInputName Then
            VBComponentNameIsUnique = False
        End If
    Next vbc
End Function

MatchesPattern

Public Function MatchesPattern( _
    strInputTest As String, _
    strInputPattern As String, _
    Optional IgnoreCase As Boolean = True, _
    Optional IsGlobal As Boolean = True _
) As Boolean
    On Error GoTo Catch
    Dim objRegExp As New RegExp
    Set objRegExp = Nothing
    objRegExp.IgnoreCase = IgnoreCase
    objRegExp.Global = IsGlobal
    objRegExp.Pattern = strInputPattern
    MatchesPattern = objRegExp.Test( _
        strInputTest _
    )
    Set objRegExp = Nothing
    Exit Function
Catch:
    Set objRegExp = Nothing
End Function

SlicerCount

Public Function SlicerCount( _
    scl As SlicerCacheLevel, _
    Optional NonBlankOnly As Boolean = True, _
    Optional Verbose As Boolean = True _
)
    Dim si As SlicerItem
    Dim iCount As Integer
    Dim iVerboseCount As Integer
    Dim iTotal As Integer
    iCount = 0
    If Verbose Then
        iVerboseCount = 0
        iTotal = scl.SlicerItems.Count
    End If
    For Each si In scl.SlicerItems
        If NonBlankOnly Then
            If SlicerItemIsPopulated(si) Then
                iCount = iCount + 1
            End If
        Else
            iCount = iCount + 1
        End If
        If Verbose Then
            iVerboseCount = iVerboseCount + 1
            Application.StatusBar = _
                "Counting Slicer Items (" & _
                Pct( _
                    iVerboseCount, _
                    iTotal _
                ) & _
                " complete)..."
        End If
    Next si
    SlicerCount = iCount
    If Verbose Then
        Application.StatusBar = False
    End If
End Function