• Posted on: 30 August 2013
  • By: greeny

Here you can find some useful functions and subroutines written by me. 

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'### Basic level of Pivot table without creating a real Pivot table

Private Function MyPivot(wsAct As Worksheet, intKeyCol As Integer, intSumCol As Integer, lngStartRow As Long, Optional bolOnlyCount As Boolean = False) As Dictionary

    

    'NOTE: Reference: Microsoft Scripting Runtime

    

    Dim lngRow As Long

    Dim dicResult As New Dictionary

    Dim varKey As Variant

    

    lngRow = lngStartRow

    Do While wsAct.Cells(lngRow, intKeyCol) <> ""

        DoEvents

        varKey = wsAct.Cells(lngRow, intKeyCol).Value

        If dicResult.Exists(varKey) Then

            dicResult.Item(varKey) = Val(dicResult.Item(varKey)) + IIf(Not bolOnlyCount, Val(wsAct.Cells(lngRow, intSumCol).Value), 1)

        Else

            dicResult.Add varKey, IIf(Not bolOnlyCount, Val(wsAct.Cells(lngRow, intSumCol).Value), 1)

        End If

        lngRow = lngRow + 1

    Loop

    Set MyPivot = dicResult

    

End Function

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'### To fill a string from LEFT or RIGHT with specified strings (for the purpose of adding leading characters, etc.)

Private Function FillFullLen(strVar As Variant, strFiller As String, intMaxLen As Integer, strDirection As String) As String

    

    Dim strToAdd As String

    

    If intMaxLen - Len(strVar) < 1 Then

        FillFullLen = Left(strVar, intMaxLen)

        Exit Function

    End If

    

    strToAdd = String(intMaxLen - Len(strVar), strFiller)

    

    Select Case strDirection

        Case "LEFT"

            FillFullLen = strVar & strToAdd

        Case "RIGHT"

            FillFullLen = strToAdd & strVar

        Case Else

        'default case

            FillFullLen = strVar & strToAdd

    End Select

    

End Function

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'### To change Excel's column number to column letters (for the purpose of using in formulas, etc).

Private Function ColNumberToColLetter(lngCol As Long) As String

    'NOTE: author unknown

    If lngCol > 26 Then

        ColNumberToColLetter = Chr(Int((lngCol - 1) / 26) + 64) & Chr(((lngCol - 1) Mod 26) + 65)

    Else

        ColNumberToColLetter = Chr(lngCol + 64)

    End If

 

End Function

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'### Used for array operations
Private Function IsArrayMember(arIn As Variant, strCompare As String) As Boolean

UPDTAE: application.Match() - does the same!

    'NOTE: arIn is a string array!

    Dim i As Double

    Dim varAct As Variant

    

    IsArrayMember = False

    For Each varAct In arIn

        If UCase(Trim(CStr(varAct))) = UCase(Trim(strCompare)) And Trim(strCompare) <> "" Then

            IsArrayMember = True

            Exit Function

        End If

    Next

    

End Function

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'### To refresh exisiting Pivot Tables
Private Sub RefreshAllPivots(wsAct As Worksheet)

 

    Dim ptAct As PivotTable

    

    For Each ptAct In wsAct.PivotTables

        With ptAct

            .PivotCache.MissingItemsLimit = xlMissingItemsNone

            .PivotCache.Refresh

        End With

    Next

        

End Sub

 

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'### To Check environmental variables (for instance: USERNAME, default temp folder etc)
Private Sub ListAllEnvironmentVariables()

 

    'NOTE: source = MS Office Help

    Dim strEnv As String

    Dim lngIndex As Long

 

    lngIndex = 1

    Do While Environ(lngIndex) <> ""

        DoEvents

        Debug.Print Environ(lngIndex)

        lngIndex = lngIndex + 1

    Loop

    

End Sub

Excel VBA Toolkit