Articles Tagged: vba

Swap Note and Formula July 25, 2005

Here are two routines that pull the formula from a note and put the formula in a note. I had a very specific need for this, but I can’t recall why now.

' Creates a formula from the Note
' Copyright under GPL by Mark Grimes

Sub mgNote2Formula()
    For Each c In Selection.Cells
        c.Formula = c.NoteText
    Next
End Sub

'
' Put the formula in the note
' Copyright under GPL by Mark Grimes
Sub mgFormulaToNote()
    For Each c In Selection.Cells
        c.NoteText (c.Formula)
    Next
End Sub

Outlook Folder List July 25, 2005

For the previous hack, I often had a hard time finding the correct folder to monitor. This bit of code will list all the top level folders for you.

' Copyright under GPL by Mark Grimes
' list folders by poping up msg box windows
Private Sub ListFolders()
    Dim objNS As NameSpace
    Dim objFolders, objFolder
    Set objNS = Application.GetNamespace("MAPI")

    ' instantiate Items collections for folders we want to monitor
    Set objFolders = objNS.Folders
    For Each objFolder In objFolders
        MsgBox objFolder.Name
    Next
    Set objNS = Nothing
End Sub

Combine Cells July 25, 2005

This routine combines the selected cells into one long string in the current cell.

' Combine cells
' Copyright under GPL by Mark Grimes

Sub mgCombineCells()
    t = ""
    For Each c In Selection.Cells
        t = t & Trim(c.Formula) & " "
    Next
    t = Left(t, Len(t) - 1)
    ActiveCell.Formula = t
End Sub

Forward E-Mails as They Are Sorted July 25, 2005

I often find myself creating a folder to store all the messages relating to a particular project, and then wanting to forward any message placed in that folder to one of my colleagues. This code, when placed in the ThisOutlookSession module, takes care of the forwarding for me.

This code was derived from Sue Mosher’s article found in Windows & .Net Magazine.

``VBScript ‘ Copyright under GPL by Mark Grimes

Option Explicit

Private WithEvents objEconomistItems As Items

‘ instantiate Items collections for folders we want to monitor Private Sub Application_Startup() Dim objNS As NameSpace Set objNS = Application.GetNamespace(“MAPI”)

Set objEconomistItems = objNS.GetDefaultFolder(olFolderInbox).Folders.Item("Mailing Lists").Folders.Item("Economist").Items
Set objNS = Nothing

End Sub

‘ disassociate global objects declared WithEvents Private Sub Application_Quit() Set objEconomistItems = Nothing End Sub

‘ Forward msg when new msg added to folder ‘ Prompt before sending Private Sub objEconomistItems_ItemAdd(ByVal Item As Object) Dim Response As Variant Dim myForward As Variant

Response = MsgBox("Forward message (" + Item.Subject + ") to Patrick & Josh?", vbYesNo)
If Response = vbYes Then
    Set myForward = Item.Forward
    myForward.Recipients.Add "Patrick (E-mail)"
    myForward.Recipients.Add "Josh (E-Mail)"
    myForward.Send
End If

End Sub ```

Auto Color Cells July 25, 2005

Many users of Excel have made it common practice to color code cells to help identify inputs, formulas, etc. For example, it is common to color all cells act as hard coded inputs (i.e. not a formula) blue, all formulas black. This Excel macro looks at the contents of each selected cell and sets the color appropriately. Further I have added the green coloring for all external references.

' Set the color of cells to blue or black respectively
' Copyright under GPL by Mark Grimes
' Keyboard Shortcut: Crtl+Shift+C

Sub mgSetColor()
    For Each c In Selection.Cells
        If Left(c.Formula, 1) = "=" Then
            If InStr(c.Formula, ".xls") Or InStr(c.Formula, ".XLS") Then
                c.Font.ColorIndex = 10
            ElseIf InStr(c.Formula, "OFFSET") Then
                c.Font.ColorIndex = 9
            Else
                allNumbers = True
                For i = 1 To Len(c.Formula) - 1
                    If (Asc(Mid(c.Formula, i, 1)) < 40) Or (Asc(Mid(c.Formula, i, 1)) > 61) Then
                        ' MsgBox "Setting false: " &amp; Mid(c.Formula, i, 0) &amp; " = " &amp; Asc(Mid(c.Formula, i, 1))
                        allNumbers = False
                        Exit For
                    Else
                        ' MsgBox Mid(c.Formula, i, 1) &amp; " = " &amp; Asc(Mid(c.Formula, i, 1))
                    End If
                Next
                If allNumbers Then
                    c.Font.ColorIndex = 5   ' blue
                Else
                    c.Font.ColorIndex = 0   ' auto
                End If
            End If
        Else
            c.Font.ColorIndex = 5
        End If
    Next
End Sub

Align Center July 25, 2005

I hate merged cells. They create all sorts of problems adding/deleting columns, filling down, etc. But it can look nice to have text centered across a range not just a single cell. Luckily, Excel provides the rarely used Align Center formatting option. This macro provides easy access to toggling the alignment formatting across all selected cells… but that’s not all… :-) it also centers the contents of a single cell if that is all that is selected.

' Toggles Align Center
' Copyright under GPL by Mark Grimes
' Keyboard Shortcur: Crtl+Shift+A
'
Sub mgCenterAlign()
    If Selection.count = 1 Then
        With Selection
            If .HorizontalAlignment = xlHAlignCenter Then
                .HorizontalAlignment = xlGeneral
            Else
                .HorizontalAlignment = xlHAlignCenter
            End If
        End With
    Else
        With Selection
            If .HorizontalAlignment = xlCenterAcrossSelection Then
                .HorizontalAlignment = xlGeneral
            Else
                .HorizontalAlignment = xlCenterAcrossSelection
            End If
        End With
    End If
End Sub

Create Spacing Rows July 25, 2005

I often want to have some space between row to call attention to a particular row, but rather than having a full row, a small row would work better. This macro will adjust the height of all the select cells if they are empty.

' Set the height of all blank selected rows to small
' Copyright under GPL by Mark Grimes
' Keyboard Shortcur: Crtl+Shift+E 
'
Sub mgShrinkSpaces()
    For Each c In Selection.Cells
        If c.Value = "" Then
            c.RowHeight = 5
        End If
    Next
End Sub

Outlook Junk Mail - Old July 25, 2005

The following code worked for older versions of Outlook (2000 I believe), but does not work for newer versions. There used to be a junk button on the toolbar. The code effectively activated that button. I’m not sure how to do it in newer version of Outlook. I have actually given up on Outlook’s spam filtering and use SpamAssassian now. You might check out Wininspector to track down the right object.

If anyone figures out a solution, please email me know. I have had several people ask about this.

This code combines the frequently used steps of adding the senders of all selected e-mails to the Outlook “Junnk Sender’s List” and then moving the messages to the junk mail folder. I then create a toolbar button associated with this “macro.”

More...