ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1055|回复: 9

[求助] 本下拉框边宽的VBA禁用了excel自带的筛选功能,如何更改代码可以正常筛选

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-10-9 14:00 | 显示全部楼层 |阅读模式
在论坛搜索到这个代码,下拉框边宽可以实现,但里面有一句禁用了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



微信图片_20191009135302.jpg

TA的精华主题

TA的得分主题

发表于 2019-10-10 06:22 | 显示全部楼层
     wks.AutoFilterMode = true

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-10 12:38 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
dushaguo 发表于 2019-10-10 06:22
wks.AutoFilterMode = true

设置为true,下拉框就不会变宽了

TA的精华主题

TA的得分主题

发表于 2019-10-10 17:14 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-24 13:20 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
今天还发现一个冲突,点下拉框时,会自动关闭NumLock,当需要在其他单元格使用数字键盘时,必须在键盘上点下开启NumLock,期待解决办法。

TA的精华主题

TA的得分主题

发表于 2019-10-24 13:29 | 显示全部楼层
解决方法不用sendkeys,手动打开下拉框

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-24 13:52 | 显示全部楼层
大灰狼1976 发表于 2019-10-24 13:29
解决方法不用sendkeys,手动打开下拉框

谢谢。同时麻烦指点下,用VBA设置了下拉框变宽,和Excel自带的筛选功能冲突了,如何解决?

下拉框变宽和正常筛选冲突.rar

16.88 KB, 下载次数: 1

TA的精华主题

TA的得分主题

发表于 2019-10-24 13:56 | 显示全部楼层
楼主,不情之请,我的系统语言关系,打开文件代码丢失,请把模块名改成英文后重新上传。另,RAR大概率打不开,尽量发ZIP格式。
以上都是我这边的问题。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-24 14:05 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
大灰狼1976 发表于 2019-10-24 13:56
楼主,不情之请,我的系统语言关系,打开文件代码丢失,请把模块名改成英文后重新上传。另,RAR大概率打不 ...

好的,先谢谢了。

下拉框变宽和正常筛选冲突.zip

17.68 KB, 下载次数: 2

TA的精华主题

TA的得分主题

发表于 2019-10-24 14:15 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
回答如下:
1、保护工作表时,勾选了自动筛选,但在保护状态下不能筛选。
    答:先在工作表内设置好自动筛选,然后再按上述方式保护工作表。
2、当不保护工作表时,选择需筛选的标题行,选择筛选菜单,点下拉箭头,
    可以使用Excel自带的筛选,但筛选完成,点任何一个单元格,则自动取消了筛选。
    答:wks.AutoFilterMode = False 注释掉这句,完整代码如下:
  1. Sub MakeValidationWidthWide(ByVal target As range, RelativeToOriginalSize)
  2.     Dim wks As Worksheet
  3.     Dim elmDic As Object
  4.     Dim elmShp As Shape
  5.     Dim drpShp As Shape
  6.     Dim objDic As Object

  7.     Set wks = target.Parent
  8.     On Error GoTo Terminate

  9.     'wks.AutoFilterMode = False '此属性设置为 false 以禁用筛选(即,移除筛选器下拉箭头),但不能将此属性设置为 true。
  10.     If target.Cells.Count > 1 Then Exit Sub '如果目标单元格多于一个,则退出
  11.      If target.Validation.Type = xlValidateList Then
  12.         Set objDic = CreateObject("Scripting.Dictionary")
  13.         For Each elmDic In wks.DrawingObjects
  14.             objDic.Add elmDic.Name, elmDic.Name
  15.         Next
  16.         For Each elmShp In wks.Shapes
  17.             If elmShp.Name Like "Drop Down *" Then
  18.                 If Not objDic.Exists(elmShp.Name) Then
  19.                     Set drpShp = elmShp
  20.                     Exit For
  21.                 End If
  22.             End If
  23.         Next
  24.         If Not drpShp Is Nothing Then
  25.             drpShp.ScaleWidth RelativeToOriginalSize, False, msoScaleFromBottomRight
  26.             
  27.         End If
  28.     End If
  29. Terminate:
  30.     Set drpShp = Nothing
  31.     Set objDic = Nothing
  32.    
  33. End Sub
复制代码

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 20:56 , Processed in 0.050664 second(s), 15 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表