|
在论坛搜索到这个代码,下拉框边宽可以实现,但里面有一句禁用了Excel的筛选功能(在保护工作表时自动筛选打勾的情况下也不能筛选;工作表不保护的情况下,必须选择标题行,然后选筛选可以实现,但其他单元格点一下,自动筛选自动取消了),如何设置代码可以实现有下拉框的单元格的下拉框边宽,标题行的单元格的筛选功能正常使用。
代码:
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
|
|