Code

  • FolderExists

    Function FolderExists( _
        strCompleteFolderPath As String _
    ) As Boolean
        Dim _
            fs As Object
        Set _
            fs = _
                CreateObject( _
                    "Scripting.FileSystemObject" _
                )
        FolderExists = _
            fs.FolderExists( _
                strCompleteFolderPath _
            )
        Set _
            fs = _
                Nothing
    End Function
  • DeleteVBACodeFromWorkbook

    Sub DeleteVBACodeFromWorkbook( _
        wb As Workbook _
    )
        Dim _
            vbc As VBComponent
        For Each vbc In wb.VBProject.VBComponents
            If vbc.Type <> vbext_ct_Document Then
                wb.VBProject.VBComponents.Remove vbc
            End If
        Next vbc
    End Sub
  • GetFilePath

    Public Function GetFilePath( _
        sFullFileNameWithPath As String _
    ) As String
        Dim fs As Object
        Set fs = CreateObject("Scripting.FileSystemObject")
        GetFilePath = _
            fs.GetAbsolutePathName( _
                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