September 24, 2007

My Son Ryan

A new addin addition to the family was downloaded delivered on Sunday morning.



Ryan was born at 33 weeks so he needs a little extra care for a while but he seems okay, his mum is doing fine too.

And I'm a dad. Wow! :-)
  

Posted by andrewe at 17:13

September 22, 2007

Option Cells

I had a requirement to imitate option buttons in a spreadsheet but using cells instead. This is what I came up with.

First I use Data Validation. Using my wife's laptop which is Japanese at the moment so no pictures, sorry. I can walk you through it though :-)

On the Settings tab, select List from Allow, then enter Y,N in Source. Make sure In-cell dropdown is ticked. Then select the Error Alert tab. Make sure Show error alert after invalid data is entered is ticked. Then select Stop for Style, enter "Input Error" for Title and "Please enter Y or N only." for Error Message. Note that I am not using Input Messages as I will be using my only version which are a bit more versatile.

To the left of the cells, I have entered Option1 in the top cell and Option2 in the bottom cell. I can give you a picture this time.



Now for the code. Go the Visual Basic Editor (Alt + F11), then select the appropiate sheet in your project. Paste in this code.

Private Sub Worksheet_Change(ByVal Target As Range)

    With Target

        If .Count > 1 Or .Column < 2 Then Exit Sub

        If .Offset(, -1).Value = "Option1" Then

            If .Value = "Y" Then
                Application.EnableEvents = False
                .Offset(1).Value = "N"
                Application.EnableEvents = True
            Else
                Application.EnableEvents = False
                .Offset(1).Value = "Y"
                Application.EnableEvents = True
            End If

        End If

        If .Offset(, -1).Value = "Option2" Then

            If .Value = "Y" Then
                Application.EnableEvents = False
                .Offset(-1).Value = "N"
                Application.EnableEvents = True
            Else
                Application.EnableEvents = False
                .Offset(-1).Value = "Y"
                Application.EnableEvents = True
            End If

        End If

    End With

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    Dim smsg As String

    With Target

        If .Count > 1 Then Exit Sub

        If .Column = 1 Then
            ActiveSheet.Shapes("shpMessage").Visible = False
            Exit Sub
        End If

        Select Case .Offset(, -1).Value
        Case "Option1"
            ShowPopupShape

            smsg = "Choose Y or N for Option1" & Chr(10)
            smsg = smsg & "(Option2 will be the opposite)"
            ActiveSheet.Shapes("shpMessage").Select
            With Selection
                With .Characters
                    .Text = smsg
                    With .Font
                        .Name = "Arial"
                        .Size = 8
                    End With
                End With
                .AutoSize = True
            End With

        Case "Option2"
            ShowPopupShape

            smsg = "Choose Y or N for Option2" & Chr(10)
            smsg = smsg & "(Option1 will be the opposite)"
            ActiveSheet.Shapes("shpMessage").Select
            With Selection
                With .Characters
                    .Text = smsg
                    With .Font
                        .Name = "Arial"
                        .Size = 8
                    End With
                End With
                .AutoSize = True
            End With

        Case Else
            ActiveSheet.Shapes("shpMessage").Visible = False

        End Select

        Application.EnableEvents = False
        .Select
        Application.EnableEvents = True

    End With

    On Error GoTo 0
End Sub

Sub ShowPopupShape()
    On Error Resume Next
    Dim shp As Shape
    Dim bshpFound As Boolean
    Dim c As Range

    bshpFound = False

    Set c = ActiveCell

    For Each shp In ActiveSheet.Shapes
        If shp.Name = "shpMessage" Then bshpFound = True
    Next shp

    If bshpFound = True Then
        With ActiveSheet.Shapes("shpMessage")
            .Left = c.Offset(, 1).Left
            .Top = c.Offset(1).Top
            .Visible = True
        End With
    Else
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        c.Offset(, 1).Left, c.Offset(1).Top, c.Width, c.Height).Select
        With Selection
            With .ShapeRange
                .Fill.ForeColor.RGB = RGB(255, 255, 204)
                .Line.Visible = msoFalse
            End With
            .Name = "shpMessage"
        End With
    End If

    Set c = Nothing

    On Error GoTo 0
End Sub

Note the Worksheet_Change code changes the value of the other cell to Y or N as necessary as this is what option buttons actually do. You will also notice I am using Autoshapes (actually just one autoshape) to the work of Input Messages used in Data Validation. Fact is you can do a lot more formatting this way, either by code or just select it the first time it appears and add wha formatting you like, all that will change afterwards is the text message according to what cells are selected. (For Excel 2007, you will have to use manual formatting the first time, should be fine after that)



With a little more code, you could make it work for more than two cells. Have fun ;-)  
Posted by andrewe at 17:19

September 17, 2007

Deleting VBA Code

There are times when you may find it useful to delete your VBA. First you will need to select your project in the Visual Basic Editor, then from the top menu, select Tools, References, then tick Microsoft Visual Basic for Applications Extensibility 5.3. Now you are ready to run one of the below examples of deletion code. (Be careful doing this, okay?)

Deleting all code in the Active Workbook
Sub DeleteAllVBACode()
    Dim oVBComp As Object

    For Each oVBComp In ActiveWorkbook.VBProject.VBComponents

        If oVBComp.Type = 100 Then
            With oVBComp.CodeModule
                .DeleteLines 1, .CountOfLines
            End With
        Else
            ActiveWorkbook.VBProject.VBComponents.Remove oVBComp
        End If

    Next oVBComp

End Sub

Deleting a module in the Active Workbook
Sub DeleteSingleCodeModule()
    Dim oVBComp As Object

    For Each oVBComp In ActiveWorkbook.VBProject.VBComponents

        If oVBComp.Name = "Module1" Then
            ActiveWorkbook.VBProject.VBComponents.Remove oVBComp
        End If

    Next oVBComp
End Sub

Deleting ThisWorkbook code in the Active Workbook
Sub DeleteThisWorkbookCode()

    With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
        .DeleteLines 1, .CountOfLines
    End With

End Sub

Deleting a Worksheet's code in the Active Workbook
Sub DeleteSheetCode()
    Dim ws As Worksheet

    With ActiveWorkbook
        For Each ws In .Worksheets
            If ws.Name = "Sheet1" Then
                With .VBProject.VBComponents(ws.CodeName).CodeModule
                    .DeleteLines 1, .CountOfLines
                End With
            End If
        Next ws
    End With
End Sub

Note that the code to delete a single module will also work with class modules and userforms as well as normal code modules. Night!
  
Posted by andrewe at 21:06

September 09, 2007

XL Help Files Maker

XL Help Files Maker is well...an XL Help Files Maker.



Although not as nice as professional Help files, you can use Excel to make some that look halfway decent. Just think - you can import pictures, add hyperlinks etc, and chances are you already know more about Excel than a completely new software. So why not?

Why not indeed. Here's the download link ;-)  
Posted by andrewe at 20:25

September 01, 2007

Resize Me

There are times when it is handy to resize a userform, perhaps to change the size of a list box so you can all items without having to scroll through them. I found a couple of ways to do this, but the one that I particularly liked was on Andy Pope's site and with his kind permission I would like to show my version here.

First, the code. Note the labels added which is where the form can be resized from. Andy does this using one label, with the clever use of Marlett font to get the right effect. The code also expands the listbox and repositions the buttons that I have added. If you have a lot of controls, it might be a better idea to loop through them, rather than write code for each one as I have done in this case.

Private WithEvents lblHeight As MSForms.Label
Private WithEvents lblWidth As MSForms.Label

Private Sub UserForm_Initialize()

    Set lblHeight = Me.Controls.Add("Forms.Label.1", "lblHeight")

    With lblHeight
        .Caption = ""
        .ControlTipText = "Drag to resize form height"
        .Left = Me.Left
        .Height = 3
        .MousePointer = fmMousePointerSizeNS
        .SpecialEffect = fmSpecialEffectSunken
        .Top = Me.Top + Me.InsideHeight - 3
        .Width = Me.InsideWidth
    End With

    Set lblWidth = Me.Controls.Add("Forms.Label.1", "lblWidth")

    With lblWidth
        .Caption = ""
        .ControlTipText = "Drag to resize form width"
        .Left = Me.Left + Me.InsideWidth - 3
        .Height = Me.InsideHeight
        .MousePointer = fmMousePointerSizeWE
        .SpecialEffect = fmSpecialEffectSunken
        .Top = Me.Top
        .Width = 3
    End With

    On Error Resume Next
    Me.Height = GetSetting("AET", Me.Name, "Height")
    Me.Width = GetSetting("AET", Me.Name, "Width")
    On Error GoTo 0

    AddDummyItems

    cbOK.SetFocus

End Sub

Private Sub lblHeight_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then Me.Height = Me.Height + Y
End Sub

Private Sub lblWidth_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then Me.Width = Me.Width + X
End Sub

Private Sub UserForm_Resize()
    On Error Resume Next

    With lblHeight
        .Top = Me.InsideHeight - .Height
        .Width = Me.InsideWidth
        lbItems.Height = .Top - 10.5
    End With

    With lblWidth
        .Left = Me.InsideWidth - .Width
        .Height = Me.InsideHeight
        lbItems.Width = .Left - 80
        cbOK.Left = .Left - 64
        cbExit.Left = .Left - 64
    End With

    On Error GoTo 0
End Sub

Private Sub cbExit_Click()
    Unload Me
End Sub

Private Sub AddDummyItems()
    Dim i As Integer

    For i = 1 To 20
        lbItems.AddItem "Item No. " & i
    Next i

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    SaveSetting "AET", Me.Name, "Height", Me.Height
    SaveSetting "AET", Me.Name, "Width", Me.Width
    Set lblHeight = Nothing
    Set lblWidth = Nothing
End Sub

Here what the form looks like in it's orginal size.



After resizing the height, all items can now be seen. Save both the height and width in the registry and the form will stay the same size when reopened.



You can find a download example file here :-)  
Posted by andrewe at 14:36