[分享]用VBA改变数据有效性序列选择列表的宽度

lhdcxz

来自:  http://www.excelfans.cn/blog/article.asp?id=122

代码:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Const ValidWidth = 2       '宽度倍数
    If Target.Validation.Value = True Then MakeValidationWidthWide Target, ValidWidth
End Sub

在模块中:

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

    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
不过有点小问题：对这个工作表里所有的数据有效性的宽度都改了。如何用简单的代码来“限制”它的“作用范围”呢？

[此贴子已经被作者于2008-7-22 11:56:00编辑过]

xymxuyimin

你可以尝试一下在加个Worksheet_SelectionChange函数中增加Taget.row和Target.column的判断条件。例如
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Taget.row=3 Then
        Const ValidWidth = 2       ' 宽度倍数
        If Target.Validation.Value = True Then MakeValidationWidthWide Target, ValidWidth
    Endif
End Sub

dengcaimao

设置了，也不行，还是禁用自动筛选。

wulai8377

不知道这个能不能同时设定下拉框的长度,只能显示8行太小了