What's in your Personal Macro Workbook?

[Nyanko]

Inspired by Chandoo's post : What would James Bond have in his Personal Macro Workbook? I was wondering what essential macros you kept to hand ?

I only have one so far which is something I found ( Mocking the ‘Merge & Center’ Icon » Bacon Bits ) a piece of code to create a Center Accross Selection button which I use instead of Merge and Center

Sub CenterAcrossSelection()
    With Selection
        If .HorizontalAlignment = xlCenterAcrossSelection Then
            .HorizontalAlignment = xlGeneral
        Else
            .HorizontalAlignment = xlCenterAcrossSelection
            .VerticalAlignment = xlCenter
        End If
    End With
End Sub

Care to share anything useful ?

 

[BrianMH]

I use this to get rid of extra white space on imported data (sometimes trim doesn't work) and to convert to dates and other formats.

Sub trimmer()
'
' trimmer Macro
'
' Keyboard Shortcut: Ctrl+t
'
    On Error GoTo ErrorHandler
    Dim rSel As Range
    Set rSel = Selection
    Dim c As Range
    Dim vCalc As Variant
    vCalc = Application.Calculation
    Dim strV
    Dim intConv As Integer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    intConv = Application.InputBox("1. Date - 2. Currency - 3. Decimal - 4. long" & Chr(13) & _
                                   "5. Don't convert just trim values" & Chr(13) & _
                                   "6. Convert international (yyyymmdd) dates to normal dates" & Chr(13) & _
                                   "7. Double", , , , , , , 1)


    Set rSel = NonEmptyCells(rSel)
    If rSel.Cells.Count > 5000 Then
        If MsgBox("You have selected a large number of cells, this may take some time, do you want to continue?", vbOKCancel) = vbCancel Then
            GoTo exiter
        End If
    End If


    Select Case intConv
        Case 1
            For Each c In rSel
                If c.Value <> "" Then
                    c.Value = CDate(Trim(c.Value))
                    c.NumberFormat = "dd-mmm-yyyy"
                End If
            Next c
        Case 2
            For Each c In rSel
                If c.Value <> "" Then
                    c.Value = CCur(Trim(c.Value))
                End If
            Next c
        Case 3
            For Each c In rSel
                If c.Value <> "" Then
                    c.Value = CDec(Trim(c.Value))
                End If
            Next c
        Case 4
            For Each c In rSel
                If c.Value <> "" Then
                    c.Value = CLng(Trim(c.Value))
                End If
            Next c
        Case 5
            For Each c In rSel


                If Trim(c.Value) = "" Then c.Value = ""
                If c.Value <> "" Then
                    strV = Trim(c.Value)
                    While Asc(Left(strV, 1)) = 127 Or Asc(Left(strV, 1)) = 129 Or Asc(Left(strV, 1)) = 141 Or Asc(Left(strV, 1)) = 143 Or Asc(Left(strV, 1)) = 144 Or Asc(Left(strV, 1)) = 157 Or Asc(Left(strV, 1)) = 160 Or Asc(Left(strV, 1)) = 10 Or Asc(Left(strV, 1)) = 13
                        strV = Right(strV, Len(strV) - 1)
                        If Not strV <> "" Then GoTo skip
                    Wend
                    While Asc(Right(strV, 1)) = 127 Or Asc(Right(strV, 1)) = 129 Or Asc(Right(strV, 1)) = 141 Or Asc(Right(strV, 1)) = 143 Or Asc(Right(strV, 1)) = 144 Or Asc(Right(strV, 1)) = 157 Or Asc(Right(strV, 1)) = 160 Or Asc(Right(strV, 1)) = 10 Or Asc(Right(strV, 1)) = 13
                        strV = Left(strV, Len(strV) - 1)
                        If Not strV <> "" Then GoTo skip
                    Wend
skip:
                    c.Value = strV
                End If
            Next c
        Case 6
            '20110131'
            For Each c In rSel
                c.NumberFormat = "General"
                If c.Value <> "" Then
                    c.Value = DateValue(Right(c.Value, 2) & "/" & Mid(c.Value, 5, 2) & "/" & Left(c.Value, 4))
                End If
                c.NumberFormat = "dd-mmm-yyyy"
            Next c
        Case 7
            For Each c In rSel
                If c.Value <> "" Then
                    c.Value = CDbl(Trim(c.Value))
                End If
            Next c
        Case False
            MsgBox ("you did not select a conversion type")
    End Select


exiter:
    Application.Calculation = vCalc
    Application.ScreenUpdating = True
    Exit Sub


ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    GoTo exiter


End Sub


Function NonEmptyCells(TestRange As Range) As Range
    Dim r1 As Range
    Dim r2 As Range
    If Not TestRange.Cells.Count > 1 Then
        Set NonEmptyCells = TestRange
        Exit Function
    End If
    On Error Resume Next
    Set r1 = TestRange.SpecialCells(xlCellTypeFormulas)
    Set r2 = TestRange.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If r1 Is Nothing And Not r2 Is Nothing Then
        Set NonEmptyCells = r2
    ElseIf r2 Is Nothing And Not r1 Is Nothing Then
        Set NonEmptyCells = r1
    ElseIf r2 Is Nothing And r1 Is Nothing Then
        Set NonEmptyCells = TestRange.Cells(1, 1)
    Else
        Set NonEmptyCells = Union(r1, r2)
    End If


End Function

I use this to get a list in CSV format (I often use this in search boxes or in sql strings)

Public Function DatatoCSV(rData As Range) As String
    Dim c As Range
    Dim strOut As String
    For Each c In rData.Cells
        If c.Value <> "" Then
            If strOut <> "" Then
                strOut = strOut & ", "
            End If
            strOut = strOut & c.Value
        End If
    Next
    DatatoCSV = strOut




End Function

This does the same with a carriage return.

Public Function DatawithCR(rData As Range) As String
    Dim c As Range
    Dim strOut As String
    For Each c In rData.Cells
        If c.Value <> "" Then
            If strOut <> "" Then
                strOut = strOut & Chr(10)
            End If
            strOut = strOut & c.Value
        End If
    Next
    DatawithCR = strOut




End Function

 

[RoryA]

I have over 15k lines of code in my personal macro workbook, all essential to me, so it's hard to choose, but I do use this a lot for changing the layout of pivot tables:

Public Sub SetPivotDefaults()
   Dim ptf               As PivotField
   With Selection.PivotTable
      .ManualUpdate = True
      ' set to tabular layout
      .RowAxisLayout xlTabularRow
      ' then format the data fields
      For Each ptf In .DataFields
         With ptf
            .Function = xlSum
            .NumberFormat = "#,##0.00"
         End With
      Next ptf
      .ManualUpdate = False
   End With
End Sub

 

[xenou]

my custom keyboard shortcuts:

Ctrl-Shift-C HardCopy (Copy-PasteSpecial Values)
Ctrl-Shift-H ShowAll (Remove Filters)
Ctrl-Shift-A Toggle Manual Calculation
Ctrl-Shift-O Toggle Gridlines
Ctrl-Shift-D Toggle MoveAfterReturnDirection (Right vs. Down)

Also my favorite formatting for cells, and my default "input cell" formatting. A send mail routine that I call from other workbooks so I have only one such procedure to maintain. In an addin that I use like personal.xls I also have my ribbon customizations and a few procedures that are business-specific (mostly related to producing different reports).

Plus my right-click customizations with more little helper routines as described in another post:
http://www.mrexcel.com/forum/excel-...izing-excel-right-click-menu-still-works.html

Plus a lot of junk that I should clean out.




Edit: Oh yeah, and I forgot this little beauty in the Workbook module:

[COLOR="Navy"]Private[/COLOR] [COLOR="Navy"]Sub[/COLOR] Workbook_Open()
    Application.OnKey "{F1}", "" [COLOR="SeaGreen"]'//I'm always hitting F1 when I want F2 - #$@$ Help Sidebar[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

 

[Jon von der Heyden]

I don't actually use PERSONAL - instead mine is set-up in my default workbook Book.xltm. I tend to remove the modules of procs/functions that I don't use before distributing my files. Here are some of my favourites:

Substitute multiple characters in a text string:

Public Function MULTISUBST(ByVal strText As String, strNewText As String, ParamArray varOldText() As Variant) As String
    Dim strReturn As String
    Dim varArray As Variant
    Dim varItem As Variant
    
    strReturn = strText
    varArray = varOldText
    Call BubbleSortLen(varArray)
    
    For Each varItem In varArray
        strReturn = Replace$(Expression:=strReturn, Find:=varItem, Replace:=strNewText, Compare:=vbTextCompare)
    Next varItem
    
    MULTISUBST = strReturn
End Function

Find text in a string in reverse order:

Public Function FINDREV(ByVal strFindText As String, ByVal strWithinText As String, Optional ByVal lngStart As Long = -1) As Long
    FINDREV = InStrRev(StringCheck:=strWithinText, StringMatch:=strFindText, Start:=lngStart, Compare:=vbTextCompare)
End Function

Concatenate a range of values according to a criterion (can also be used for concatenating a range of values):

Public Function CONCATENATEIF(ByVal rngCriteriaRange As Excel.Range, _
                              ByVal varCriteria As Variant, _
                              ByVal rngValues As Excel.Range, _
                              Optional ByVal strDelimiter As String = " ") As Variant
    Dim lngRows As Long, lngCols As Long
    Dim blnErr As Boolean, lngErr As XlCVError
    Dim strCritAddress As String
    Dim strValAddress As String
    Dim varOperators As Variant: varOperators = VBA.Array("=", "<>", ">", "<", ">=", "<=")
    Dim strOperator As String
    Dim varResults As Variant


    With rngCriteriaRange
        lngRows = .Rows.Count
        lngCols = .Columns.Count
    End With


    '#REF! if 2D criteria range is passed
    blnErr = CBool(lngRows > 1 And lngCols > 1)
    If blnErr Then
        lngErr = xlErrRef
        GoTo err_exit
    End If


    '#VALUE! if values range dimension is not the same size and orientation as criteria range
    With rngValues
        blnErr = CBool(lngRows <> .Rows.Count)
        blnErr = CBool(blnErr Or lngCols <> .Columns.Count)
        If blnErr Then
            lngErr = xlErrValue
            GoTo err_exit
        End If
    End With


    '#N/A if the criteria is an array (or more than one cell)
    blnErr = IsArray(varCriteria)
    If blnErr Then
        lngErr = xlErrNA
        GoTo err_exit
    End If


    'Split the operator from the criteria, if an operator has been included
    strOperator = Left$(varCriteria, 2)
    If IsNumeric(Application.Match(strOperator, varOperators, 0)) Then
        varCriteria = Mid$(varCriteria, 3)
    Else
        strOperator = Left$(varCriteria, 1)
        If IsNumeric(Application.Match(strOperator, varOperators, 0)) Then
            varCriteria = Mid$(varCriteria, 2)
        Else
            strOperator = "="
        End If
    End If


    'Make sure the criteria type is correct, and concatenate the operator with the criteria
    If IsDate(varCriteria) Then
        varCriteria = strOperator & CDbl(varCriteria)
    Else
        If IsNumeric(varCriteria) Then
            varCriteria = strOperator & varCriteria
        Else
            varCriteria = strOperator & Chr$(34) & varCriteria & Chr$(34)
        End If
    End If


    'Get the addresses of the criteria and values ranges
    strCritAddress = rngCriteriaRange.Address(external:=True)
    strValAddress = rngValues.Address(external:=True)


    'Construct an array of the results
    If lngRows > 1 Then
        varResults = Evaluate("transpose(if(" & strCritAddress & varCriteria & "," & strValAddress & "))")
    Else
        varResults = Evaluate("if(" & strCritAddress & varCriteria & "," & strValAddress & ")")
    End If


    'Remove non-matching items from the array, and concatenate the remaining items
    varResults = Filter(varResults, False, False)
    CONCATENATEIF = Join$(varResults, strDelimiter)


    Exit Function


err_exit:
    CONCATENATEIF = CVErr(lngErr)
End Function

Validate a serial date value:

Public Function ISDATENUMBER(ByVal rngCell As Excel.Range) As Boolean
    ISDATENUMBER = IsDate(rngCell.Text) And IsNumeric(rngCell.Value2)
End Function

Validate a serial time value:

Public Function ISTIMENUMBER(ByVal rngCell As Excel.Range) As Boolean
    ISTIMENUMBER = IsDate(rngCell.Text) And Not IsDate(rngCell.Value) And IsNumeric(rngCell.Value2)
End Function

Create random numbers within value constraints:

Public Function RANDBETWEENA(ByVal dblLower As Double, _
                             ByVal dblUpper As Double, _
                             Optional lngDecimals As Long = 5, _
                             Optional blnVolatile As Boolean = False) As Variant()
    
    Dim rngArea As Excel.Range, lngItem As Long, lngRow As Long, lngCol As Long
    Dim varResult As Variant, varResults() As Variant, varTemp() As Variant
    Dim lngMaxIterations As Long
    
    If blnVolatile Then Application.Volatile
    
    If StrComp(TypeName(Application.Caller), "Range", vbBinaryCompare) <> 0 Then
        Call Err.Raise(Number:=vbObjectError + 1024, Description:="RandbetweenA is only callable from a range!")
        Exit Function
    End If
    
    lngMaxIterations = dblUpper * (10 ^ lngDecimals) - dblLower * (10 ^ lngDecimals) + 1
    
    Set rngArea = Application.Caller
    ReDim varResults(1 To rngArea.Rows.Count, 1 To rngArea.Columns.Count)
    ReDim varTemp(1 To rngArea.Count)
    
    For lngRow = 1 To rngArea.Rows.Count
        For lngCol = 1 To rngArea.Columns.Count
            lngItem = lngItem + 1
            If lngItem <= lngMaxIterations Then
                Do
                    varResult = (dblUpper - dblLower) * Rnd() + dblLower
                    varResult = Round(varResult, lngDecimals)
                Loop Until IsError(Application.Match(varResult, varTemp, 0))
            Else
                varResult = CVErr(xlErrNum)
            End If
            varTemp(lngItem) = varResult
            varResults(lngRow, lngCol) = varResult
        Next lngCol
    Next lngRow
    
    RANDBETWEENA = varResults
End Function

Supporting sub for MULTISUBST:

Public Sub BubbleSortLen(ByRef varArray As Variant)
    Dim i As Long, j As Long
    Dim strTemp As String
    
    For i = LBound(varArray) To UBound(varArray) - 1
        For j = i To UBound(varArray)
            If Len(varArray(j)) > Len(varArray(i)) Then
                strTemp = varArray(i)
                varArray(i) = varArray(j)
                varArray(j) = strTemp
            End If
        Next j
    Next i
End Sub

Not all my own work, I should add!

I have others, mostly string manipulation, to emulate Join, Split and other VB functions... I also have some wrapper classes in a "code library workbook" that I sometimes refer to, such as an ADO class for interfacing with DB's... I also have some of Jaafar's wonderful API procs and things to sex up userforms...

I also have certain names added to my workbook, including:
BigNum: =10^308
BigText: =REPT("Z",255)

And a bunch of constants, e.g:
xlASTERISK: ="*"
xlNULLSTRING: =""
xlSPACE: =" "

It's often easier to refer to the constants by the values but sometimes it's nice to be able to see the value by its constant name in the formula.

I have a number of other names too, but I think we've discussed them before (refer to shg for his list )...