June 28, 2005

Highlight Blank Fields

This is something I use as a reminder when something needs to be filled out in a form (invoices etc made on Excel spreadsheets).

From the main menu, choose Format, Conditional Formatting, Cell Value Is and enter ="". Then push the Format button on the right to select a suitable "highlight" of choice.



By highlighting these "must fill out" fields (cells) when blank, it's kind of hard to miss the obvious.

If you find yourself using this a lot, the following code makes it just a little faster by assigning a macro button. (Keep in mind it will delete any existing conditional formats first)

Sub HighlightBlankCells()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim c As Range, myRange As Range
    Set c = ActiveCell
    Set myRange = Selection
    For Each c In myRange
        With c
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="="""""
            .FormatConditions(1).Interior.ColorIndex = 4
        End With
    Next
    myRange.Select
    Application.ScreenUpdating = True
End Sub

For the "purists" you can use Formula is =ISBLANK(INDIRECT(ADDRESS(ROW(),COLUMN()))) to pick up unwanted "fluff" (to make sure cells are truly blank), generally speaking though Cell Value Is ="" should work just fine ;-)  

Posted by andrewe at 21:19

June 21, 2005

Another AutoShape Graph

Seeing that Ross expressed his impeccably good taste in approving my previous AutoShape graphs, I decided to include another. This one is rather interesting in that it works "backwards".

Sub PieChart()
    On Error Resume Next
    Dim myRange As Range, i As Long, mySum As Long, myArc As Long, ChrtColor As Long
    Set myRange = Selection
    mySum = Application.Sum(myRange)
    ChrtColor = 47
    myArc = 360
    ActiveCell(, myRange.Cells.Count).Select
    For i = 1 To myRange.Cells.Count
        ActiveSheet.Shapes.AddShape(msoShapeArc, 216, 57, 85, 85).Select
        With Selection
            With .ShapeRange
                .Flip msoFlipHorizontal
                .IncrementRotation 90#
                .Adjustments.Item(1) = myArc
                .Fill.ForeColor.SchemeColor = ChrtColor
                .Fill.Solid
                .Line.Weight = 2.25
                .Line.ForeColor.SchemeColor = 12
                .ZOrder msoBringToFront
            End With
        .Name = "myLines" & i
        End With
        If ChrtColor = 47 Then ChrtColor = 45 Else ChrtColor = ChrtColor + 1
        myArc = myArc - ((360 / mySum) * ActiveCell.Value)
        ActiveSheet.Shapes.Range(Array("myLines", "myLines" & i)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "myLines"
        ActiveCell.Offset(, -1).Select
    Next
    myRange.Select
End Sub



Pie Charts. Yum yum. The updated file is available here.  
Posted by andrewe at 22:28

June 18, 2005

More Graphs from AutoShapes

Here's some more code I wrote to make different types of AutoShape graphs.

A 3D bar graph -

Sub BarGraph()
    On Error Resume Next
    Dim c As Range, myRange As Range, i As Long, grpHeight As Long, cntr As Long, BarColor As Long
    Set myRange = Selection
    BarColor = 10
    For i = 1 To Selection.Cells.Count
        grpHeight = ActiveCell.Offset(-ActiveCell.Value, 0).Top
        cntr = ActiveCell.Offset(0, 1).Left - ((ActiveCell.Width / 4) * 2) - ActiveCell.Left
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left + (ActiveCell.Width / 4), _
                grpHeight, cntr, ActiveCell.Offset(0, 0).Top - grpHeight).Select
        With Selection
            With .ShapeRange
                .Fill.Transparency = 1
                .Fill.BackColor.SchemeColor = BarColor
                .Fill.TwoColorGradient msoGradientHorizontal, 1
                .ThreeD.SetThreeDFormat msoThreeD1
                .ThreeD.ExtrusionColor.SchemeColor = BarColor
            End With
            .Name = "myLines" & i
        End With
        ActiveSheet.Shapes.Range(Array("myLines", "myLines" & i)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "myLines"
        Cells(ActiveCell.Row, ActiveCell.Column + 1).Select
        If BarColor = 12 Then BarColor = 10 Else BarColor = BarColor + 1
    Next
    myRange.Select
End Sub



A line graph -

Sub LineGraph()
    On Error Resume Next
    Dim c As Range, myRange As Range, i As Long
    Dim gridNo As Long, grpHeight As Long, grpHeight2 As Long, cntr As Long
    Set myRange = Selection
    For Each c In Selection
        c.Formula = "=INT(RAND()*10)+1"
    Next
    ActiveSheet.Shapes("myGraph").Delete
    myRange.Select
    For i = 1 To Selection.Cells.Count - 1
        grpHeight = ActiveCell.Offset(-ActiveCell.Value, 0).Top
        grpHeight2 = ActiveCell.Offset(-ActiveCell.Offset(0, 1).Value, 1).Top
        cntr = ActiveCell.Left + (ActiveCell.Offset(0, 1).Left - ActiveCell.Left) / 2
        ActiveSheet.Shapes.AddLine(cntr, grpHeight, cntr + ActiveCell.Offset(0.1).Width, grpHeight2).Select
        With Selection
            .ShapeRange.Line.ForeColor.SchemeColor = 12
            .ShapeRange.Line.Weight = 2
            .Name = "myLines" & i
        End With
        ActiveSheet.Shapes.Range(Array("myLines", "myLines" & i)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "myLines"
        Cells(ActiveCell.Row, ActiveCell.Column + 1).Select
    Next
    myRange.Select
    For i = 1 To Selection.Cells.Count
        grpHeight = ActiveCell.Offset(-ActiveCell.Value, 0).Top
        cntr = ActiveCell.Left + (ActiveCell.Offset(0, 1).Left - ActiveCell.Left) / 2
        ActiveSheet.Shapes.AddShape(msoShapeOval, cntr - 4.5, grpHeight - 4.5, 9, 9).Select
        With Selection
            .ShapeRange.Line.ForeColor.SchemeColor = 12
            .ShapeRange.Fill.ForeColor.SchemeColor = 12
            .Name = "myDots" & i
        End With
        ActiveSheet.Shapes.Range(Array("myDots", "myDots" & i)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "myDots"
        Cells(ActiveCell.Row, ActiveCell.Column + 1).Select
    Next
    ActiveSheet.Shapes.Range(Array("myLines", "myDots")).Select
    Selection.ShapeRange.Group.Select
    Selection.Name = "myGraph"
    myRange.Select
End Sub



And a few more which you can download here.

For Excel 97 users, the transparency properties may cause a problem, just remove the offending lines of code (if any). They should be highlighted yellow if there's a need to debug.  
Posted by andrewe at 17:09

June 15, 2005

Multi Menu Maker

This is a little something I made last Sunday. It's inspired by John Walkenbach's original and classic Menu Maker and Masaru Kaji's (aka Colo) very convenient Menu Generator.



I was just going to make something for Toolbars, but decided I might as well write it to work with the Main Menu and Right-Click Menu as well. It's designed to be a simplified alternative to Colo's version so that it can be used with Excel 97 (Thanks Colo for testing!), at the same time, you have to manually copy the worksheet and code to your target file/add-in. Not too much trouble I hope ;-)

Hope it comes in useful, you can download it here.  
Posted by andrewe at 21:21

June 07, 2005

Graphs From AutoShapes

Last time I used formulas and conditional formatting to make graphs. At the time I wondered about making them with AutoShapes so I played around with the idea today. This is the result.

This is the "basic" code. Select a row of numbers and the code will make a graph from them. (Note that I group the AutoShapes at the end, it's not necessary, it just keeps the graph intact if you want to copy or move it to another location)

Sub InstantBarGraph()
On Error Resume Next
    Dim c As Range, myRange As Range, i As Long
    Dim gridNo As Long, grpHeight As Long, cntr As Long
    Set myRange = Selection
    For i = 1 To Selection.Cells.Count
        grpHeight = ActiveCell.Offset(-ActiveCell.Value, 0).Top
        cntr = ActiveCell.Left + (ActiveCell.Offset(0, 1).Left - ActiveCell.Left) / 2
        ActiveSheet.Shapes.AddLine(cntr, grpHeight, cntr, ActiveCell.Top).Select
        With Selection
            .ShapeRange.Line.ForeColor.SchemeColor = 12 ' Blue = 12, Red = 10, Black = 0
            .ShapeRange.Line.Weight = 6
            .Name = "myLines" & i
        End With
        ' Make it easy to (re)move the lines
        ActiveSheet.Shapes.Range(Array("myLines", "myLines" & i)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "myLines"
        Cells(ActiveCell.Row, ActiveCell.Column + 1).Select
        Next
    myRange.Select
End Sub

This will give me something like this.



I can add some borders to make it look a little more sophisticated, but in this example file I decided to add more AutoShapes to do it instead.



So, is this useful? Well, I believe that depends from what you want from a graph in the first place. As the graph is made from AutoShapes you can do some interesting stuff just be selecting them with the cursor, keep the Ctrl key depressed when selecting with multiple shapes. Here's a few things you can try, (some can be done with regular graphs also).

  • Enter and Format Text in Shapes
  • Add 3D or Shadow formatting
  • Change Colors, Patterns or Texture *
  • Change Line Formatting
  • Flip, Turn or Rotate
  • Add Images Files
  • Add Hyperlinks
  • Link To Cells or Macros

    (* including transparency depending on your Excel version)



    You can also copy and paste them, or use an Image Editor to make them gif, jpg files etc.

    You'll have to change or add some properties if you want to do it with VBA. You can click any of the AutoShapes and run the recorder as you make the changes to learn what needs to be done.

    Have fun ;-)  
  • Posted by andrewe at 22:38

    June 05, 2005

    Inserting x Rows at Set Intervals

    Here's a little code I wrote today for inserting any number of rows at any interval of rows specified.

    Sub InsertRowsAtIntervals()
        On Error Resume Next
        Dim c As Range, i As Long, rwu As Long, rwl As Long
        Dim rwc As Long, rwNo As Long, rwCount As Long
        If TypeName(Selection) <> "Range" Then Exit Sub
        Set c = Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + Selection.Columns.Count - 1))
        rwCount = Selection.Rows.Count
        rwNo = InputBox("Enter row interval. ", "Insert Rows at Intervals", 1)
        rwl = InputBox("How many rows to insert at each interval? ", "Insert Rows at Intervals", 1)
        rwu = ActiveCell.Row + rwNo
        rwc = rwl + rwNo
        For i = 1 To Int(rwCount / rwNo)
            Range(Cells(rwu, ActiveCell.Column), Cells(rwu + rwl - 1, ActiveCell.Column)).Select
            Selection.EntireRow.Insert
            rwu = rwu + rwc
        Next
        Range(c, Selection).Select
    End Sub

    This is for columns.

    Sub InsertColumnsAtIntervals()
        On Error Resume Next
        Dim c As Range, i As Long, clu As Long, cll As Long
        Dim clc As Long, clNo As Long, clCount As Long
        If TypeName(Selection) <> "Range" Then Exit Sub
        Set c = Range(ActiveCell, Cells(ActiveCell.Row + Selection.Rows.Count - 1, ActiveCell.Column))
        clCount = Selection.Columns.Count
        clNo = InputBox("Enter column interval. ", "Insert Columns at Intervals", 1)
        cll = InputBox("How many columns to insert at each interval? ", "Insert Columns at Intervals", 1)
        clu = ActiveCell.Column + clNo
        clc = cll + clNo
        For i = 1 To Int(clCount / clNo)
            Range(Cells(ActiveCell.Row, clu), Cells(ActiveCell.Row, clu + cll - 1)).Select
            Selection.EntireColumn.Insert
            clu = clu + clc
        Next
        Range(c, Selection).Select
    End Sub

    Both of these are included with my utilities ;-)  
    Posted by andrewe at 01:09