VBA TIPS
Widen the list width of the Data Validation

Usually, the list of the Data Validation is displaied as the same width as the width of a cell. Therefore, it may not be displayed when the character sequence used for the Data Validation list is long. But how can we make it possible to widen the width of the list?



The following code makes it possible. Please have a look at the picture below. It can be done changing ScaleWidth property of the Shape named Drop Down brabrabra...

But it was difficult to use in case many of the Data Validations are used on a worksheet. Because it was difficult to judge that which "Drop Down" belongs to the selected Validation.

The idea using a Dictionary Object originate from my friend bykin. The Dictionary Object is an object that stores data key, item pairs. It's something like the Collection Object in VBA.

You can learn more about Dictionary Object at MSDN.
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/script56/html/jsobjDictionary.asp



Example

Place the following in a worksheet module.

Option Explicit


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Const ValidWidth = 2 'Change here to change the width of the Data Validation list
    If Target.Column = 1 Then MakeValidationWidthWide Target, ValidWidth
End Sub


Place the following in a standard module.

Option Explicit


Sub MakeValidationWidthWide(ByVal Target As Range, RelativeToOriginalSize)
    Dim wks As Worksheet
    Dim elmDic As Object
    Dim elmShp As Shape
    Dim drpShp As Shape
    Dim objDic As Object

    Set wks = Target.Parent
    On Error GoTo Terminate

    'When the AutoFilter is used in the worksheet
    'this procedure fails, so turn off the AutoFilter
    wks.AutoFilterMode = False

    If Target.Cells.Count > 1 Then Exit Sub

    If Target.Validation.Type = xlValidateList Then
        Set objDic = CreateObject("Scripting.Dictionary")
        For Each elmDic In wks.DrawingObjects
            objDic.Add elmDic.Name, elmDic.Name
        Next
        For Each elmShp In wks.Shapes
            If elmShp.Name Like "Drop Down *" Then
                If Not objDic.Exists(elmShp.Name) Then
                    Set drpShp = elmShp
                    Exit For
                End If
            End If
        Next
        If Not drpShp Is Nothing Then
            drpShp.ScaleWidth RelativeToOriginalSize, False, msoScaleFromBottomRight
            SendKeys "%{down}"
        End If
    End If
Terminate:
    Set drpShp = Nothing
    Set objDic = Nothing
End Sub

| HOME |
Copyright © cellmasters.net - colo's junk room All Right Reserved
ABOUT
WORKS
THE CELL MASTERS
CONTACT
LINKS
Tips and Information about Microsoft Excel|Masaru Kaji aka Colo