October 26, 2005

Application Events - A Class Module Example

Colo showed me how to use an Application Event when I was making Cell Spotter. Rather than apply to just one worksheet or workbook, the application level DoubleClick event that Cell Spotter uses applies to all open workbooks.

So I was thinking the other day how I could use this to show file locations in the title bar when I open workbooks. (The Full Name gets a bit long and won't always fit inside the title bar, so I just settled for the drive where the file is stored)

Here's to how to do it.

First go to the Visual Basic Editor. (Push the Alt + F11 keys) Then add a standard module and insert this code.

Public XL As New ShowDrive

Private Sub Auto_Open()
    Set XL.App = Application
End Sub

Then add a Class Module and add this code. (The Class Module name must be the same as after where it says "New" in the code above - in this case "ShowDrive")

Public WithEvents App As Excel.Application

Private Sub App_WorkbookOpen(ByVal Wb As Excel.Workbook)
    On Error Resume Next
    If Wb.Name <> "PERSONAL.XLS" Then _
        ActiveWindow.Caption = Left(Wb.FullName, 2) & " " & Wb.Name
End Sub

Note this code only works if the workbook is saved (New workbooks don't really have full names until they are saved, also the Personal.xls file has been coded out using If...Then...)

Hmm, this works fine but a problem occurs when the file is saved. If the drive is different I won't have any way of checking if the drive has changed because a BeforeSave event can't be used in this case, not as far as I know anyway :-)

So I added this SelectionChange code instead. This works when other cells are selected so it should work assuming you select some cells after saving.

Make sure it's placed in the class module too.

Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    On Error Resume Next
    If Len(Application.Substitute(Sh.Parent.Name, ".xls", "")) <> Len(Sh.Parent.Name) Then _
        ActiveWindow.Caption = Left(Sh.Parent.FullName, 2) & " " & Sh.Parent.Name
End Sub

Now for the final step. Close the Visual Basic Editor, then save the workbook as an add-in by selecting Save As from the File Menu, then Microsoft Excel Add-In from the "Save as type:" drop down list under where it says "File name:".

Go to Tools, Add-Ins and install it. (Use the Browse button to find add-ins not shown in the list)

Keep in mind the ShowDrive class module is where the event code works, you can adjust it to do whatever you like ;-)  

Posted by andrewe at 23:20

October 07, 2005

Bar Graphs In Cells 3

Today I was trying to think a way to get around the difference in transparency between Excel versions. This is a possible solution - try something else ;-)

As you can see I simply adjusted the height - on the left, using a single color, on the right using a gradient with two colors.



Here's the code with some comments shown to get different effects.

Sub BarGraphsInCells4()
    On Error Resume Next
    Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
    Set theRange = Selection
    LoopCount = 1
    For Each Cell In theRange
        BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9 ' Adjust width
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Offset(1).Top - 1.5, BarWidth, 1.5). _
                Select
        With Selection
            .ShapeRange.Line.Visible = msoFalse ' remove to show lines
            .ShapeRange.Fill.ForeColor.SchemeColor = 48 ' change color to suit
            .ShapeRange.Fill.BackColor.SchemeColor = 11 'remove for a single color, change color to suit
            .ShapeRange.Fill.TwoColorGradient msoGradientVertical, 1 'remove for no gradient
            .ShapeRange.Height = 2
            .Name = "The Bars" & LoopCount
        End With
NextStep:
        ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "The Bars"
        Cell.Offset(1).Select
        LoopCount = LoopCount + 1
    Next
    theRange.Select
End Sub

One advantage is you can enter into the cells a lot easier than before. If you want to see the code run automatically, select a range, type a name in the Name Box and push Enter (I've used "MyRange" in this case). Then enter this code in the appropriate sheet under Microsoft Excel Objects in the Visual Basic Editor.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.ScreenUpdating = False
    If Not Intersect(ActiveCell, Range("MyRange")) Is Nothing Then
        Shapes("The Bars").Delete
        Range("MyRange").Select
        BarGraphsInCells4
        Target.Select
    End If
    Application.ScreenUpdating = True
End Sub

Keep in mind calculation may be slowed down somewhat. Use accordingly :-)  
Posted by andrewe at 22:05

October 06, 2005

Bar Graphs In Cells 2

Continuing from my last post - I had a little spare time today so I decided to experiment a little more with the appearance. Here's my improved code to get the same kind of gradient effect as shown below (rather than just transparency)

Sub BarGraphsInCells2()
    On Error Resume Next
    Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
    Set theRange = Selection
    LoopCount = 1
    For Each Cell In theRange
        BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
            Select
        With Selection
            .ShapeRange.Line.Visible = msoFalse
            .ShapeRange.Fill.Transparency = 0.8
            .ShapeRange.Fill.ForeColor.SchemeColor = 48
            .ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.5
            .Name = "The Bars" & LoopCount
        End With
        ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "The Bars"
        Cell.Offset(1).Select
        LoopCount = LoopCount + 1
    Next
    theRange.Select
End Sub

This seems to be getting close.



The next trick was to add a little extra in the way of conditioning. I used CBool to get a TRUE condition, otherwise skip the part where AutoShapes are added, then go to the next step, which I very orginally named "NextStep" :-)

Here's an example that looks for the 5 highest values using RANK (be warned that this works a little strange in the case of duplicates).

Sub BarGraphsInCells3()
    On Error Resume Next
    Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
    Set theRange = Selection
    LoopCount = 1
    For Each Cell In theRange
    If Not CBool(Application.Rank(Cell, theRange) <= 5) Then GoTo NextStep
        BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
            Select
        With Selection
            .ShapeRange.Line.Visible = msoFalse
            .ShapeRange.Fill.Transparency = 0.8
            .ShapeRange.Fill.ForeColor.SchemeColor = 10 'change the color here!
            .ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.5
            .Name = "The Bars" & LoopCount
        End With
NextStep:
        ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "The Bars"
        Cell.Offset(1).Select
        LoopCount = LoopCount + 1
    Next
    theRange.Select
End Sub

If you wanted to run the code without any extra conditions, just place an apostrophe in front of the CBool line to "deactivate" it (making it a comment instead of working code)

Okay, let's take it a step further...first run the code to include all cells with a .ShapeRange.Fill.ForeColor.SchemeColor property of 10, then go to the Name Box and enter a new name for the grouped AutoShapes (eg "All The Bars") and push Enter. Then run the code again using a different SchemeColor (48) and use CBool to find the top 5 values as above. Enter a new name, say "The Top 5 Bars". Then let's try it again changing the CBool part to select all all values equal to or over 20 with a SchemeColor of 11. Rename to suit, "All Bars Over 20". (This renaming part is real hard work)

If obscured, right click the last group and select Order, Send Backward. You should end up with something like this.



Not bad for a hack (the code, not me) but as has been mentioned in my former post, not nearly as good as built-in Conditional Formatting where the colors change automatically (no code necessary). Then again the you can keep the grouped AutoShapes as "hardcopies", writing the condition may be a little simpler too depending on what you are trying to achieve. Then again, this is just one imitation format, I can only wait in anticipation to see what kind of tricks can be performed with Excel 12 ;-)

PS. Thanks Rembo for letting me know about the different row heights!  
Posted by andrewe at 20:31

Bar Graphs In Cells

I just saw a future conditional format coming up in Excel 12 via the J-Walk Blog and thought I would try to imitate it. Note: This should work fine with Excel 2002 and 2003, I'm not sure about earlier versions but you can give it a try. (The transparency feature might not work as well though)

Here's the real McCoy... (picture from David Gainer's Microsoft Excel blog)



And here's the code I used with Autoshapes...

Sub BarGraphsInCells()
    On Error Resume Next
    Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
    Set theRange = Selection
    LoopCount = 1
    For Each Cell In theRange
        BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.7 ' Adjust to suit
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
                Select
            With Selection
                .ShapeRange.Fill.ForeColor.SchemeColor = 12
                .ShapeRange.Line.Visible = msoFalse
                .ShapeRange.Fill.Transparency = 0.8
                .Name = "The Bars" & LoopCount
            End With
        ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "The Bars"
        Cell.Offset(1).Select
        LoopCount = LoopCount + 1
    Next
    theRange.Select
End Sub

And the result...



Hmm, not too bad considering it's way past my bedtime. Night!  
Posted by andrewe at 01:10

October 03, 2005

A Better Way To Search

The other day I wrote a simple macro called SelectCellsLike. It was rather limited in what it could do so I decided to make some improvements and use both Like and COUNTIF for working with wildcards or simple equations like below. (Quotation marks are not required)

  • * for 0 - multiple characters like E*el or *cel or Ex* for Excel

  • ? for single characters like ?xcel or Exc?l in the same way

  • # for single digits, ## for double digits etc

  • *#.#* in combinations to look for decimals etc

  • =Excel or =100 to find an exact match

  • >100 or <=200 can be used as well


  • To search an entire sheet, select one cell only, otherwise make a selection with you mouse and the search will apply to those cells only. (This is similar to the way that the Find dialog box works but the search ability is somewhat expanded)

    Note: Searches are not case sensitive, dates are ignored but you can search for them in a non-date format. You can also search for blank cells. (I thought this might come in handy for some ;-))

    Sub DataSearch()
        On Error Resume Next
        Dim myString As String, c As Range, myRange As Range, rFind As Range
        myString = InputBox("Enter your search string." & vbNewLine & vbNewLine _
                    & "Use Wildcards like * ? # or expressions like >100", "Data Search")
        If Selection.Cells.Count > 1 Then Set myRange = Selection Else Set myRange = ActiveSheet.UsedRange
        For Each c In myRange
            If Application.CountIf(c, myString) = 1 Or c Like myString Then
                If Not Application.IsError(c) And Not IsDate(c) Then
                    If rFind Is Nothing Then
                        Set rFind = c
                    Else
                        Set rFind = Union(rFind, c)
                    End If
                End If
            End If
        Next
        rFind.Select
    End Sub

    Once your cells are selected, you can delete, color, lock them or whatever takes your fancy. Don't forget you can enter values or formulas simultaneously into multiple cells with the Ctrl and Enter keys (pushing both keys at the same time).  
    Posted by andrewe at 23:57