模糊输入自动过滤，不错的版本

ysjjess

经过YZC51修改，我觉得是很不错的版本，有不同的，自己进去修改吧，一般就是区域不同，查看代码处有标识，小白也能改，用的是2007版的，其他版本的有没有问题我就不知道了。更新了附件，用得着的重新下载吧，再次感谢YZC51!


补充内容 (2020-2-21 09:44):
有需要的自己下载最新版，支持数字、字母（大小写都可以）、汉字过滤，在53楼，也置顶了，就在下面，本楼的有不完美的地方

ysjjess

这个数字，字母，汉字都可以模糊过滤，数据源AB二列模糊数据过滤，还增加多列数据写入，有用得着的自己下载，看到群里有一个数据源表里没有的，相应单元格填写好后自动写入到数据源最下方，这个功能也不错，但我加入的代码只能写入二列数据，所以就不弄了，希望会的加入代码或是告诉我用什么代码，多谢！
还有一个问题是，在输入数据源没有的文字，回车后就出错381，也希望会的修改后分享给大家


补充内容 (2020-1-27 12:22):
有需要的自己下载最新版，支持数字、字母（大小写都可以）、汉字过滤，在53楼，也置顶了，就在下面，本楼的有不完美的地方

ysjjess

本表支持数字、字母（大小写都可以）、汉字过滤，同时做了二个工作表可用，因为想到有的人有入库单就有出库单，分开比较好，格式还不同好自己调整，本来想做一个进销存管理系统的，但本人小白，没法做，网上有好多EXCEL做的进销存，功能都比较强大，但在单据录入方面不够灵活，希望高手能把这样的版本做成进销存管理系统，分享出来。

补充内容 (2020-2-7 19:30):
在Private Sub Worksheet_SelectionChange(ByVal Target As Range)下面加入以下代码，全选工作表也不会出现错误提示
On Error Resume Next
暂时没发现有问题的地方了，现在觉得最不完美的是文本框各列不随着数据变动

ggmmlol

木有看到代码......

ysjjess

ggmmlol 发表于 2020-1-14 13:41
木有看到代码......

这个是没有代码的，我希望师傅们自己有自己的代码，我怕别人的不一样，所以就用没有代码的

ysjjess

ggmmlol 发表于 2020-1-14 13:41
木有看到代码......

你好！我就是用这样的来改的，主要就是复制内容不能粘贴

网海遨游

这是数编码查找代码，请测试


Sub 数字编码查找()
    Dim arr(1 To 2), r%, sht As Worksheet
    Set sht = Sheets("名称")
    r = sht.Cells(Rows.Count, 1).End(3).Row
    Set d = CreateObject("scripting.dictionary") '字典
    arr(1) = sht.Range("a1:b" & r)
    arr(2) = sht.Range("c1:d" & r)
    For i = 1 To 2
        For j = 2 To UBound(arr(i))
            s = arr(i)(j, 1)
            d(s) = arr(i)(j, 2)
        Next j
    Next i
    brr = Sheets("sheet1").[a1].CurrentRegion
    For i = 2 To UBound(brr)
        s1 = brr(i, 2)
        brr(i, 4) = d(s1)
    Next
    Sheets("sheet1").[d2:d60000].Clear
    Sheets("sheet1").[a1].CurrentRegion = brr
End Sub

ysjjess

网海遨游 发表于 2020-1-14 15:47
这是数编码查找代码，请测试

多谢！我试试

网海遨游

文本编码查找


Sub 文本编码查找()
    Dim arr, r%, sht As Worksheet
    Set sht = Sheets("名称")
    r = sht.Cells(Rows.Count, 6).End(3).Row
     Set d = CreateObject("scripting.dictionary") '字典
    arr = sht.Range("f1:h" & r)
    For j = 2 To UBound(arr)
            s = arr(j, 1)
            d(s) = Array(arr(j, 2), arr(j, 3))
        Next j
        r1 = Sheets("做了").Cells(Rows.Count, 2).End(3).Row
        Sheets("做了").[c2:d60000].Clear
    For i = 2 To r1
        s1 = Sheets("做了").Cells(i, 2).value
        Sheets("做了").Cells(i, 3).Resize(, 2) = d(s1)
    Next
End Sub

YZC51

ysjjess 发表于 2020-1-14 15:26
你好！我就是用这样的来改的，主要就是复制内容不能粘贴

        If Target.Column = 2 And Target.Row > 5 And Target.Row < 17 Then
修改为
        If Target.Column = 2 And Target.Row > 1 And Target.Row < 17 Then

ysjjess

YZC51 发表于 2020-1-14 16:09
If Target.Column = 2 And Target.Row > 5 And Target.Row < 17 Then
修改为
        If Targe ...

谢谢你！本来上次是你帮我改了好多，但就二个问题没实现，看来还是只有麻烦你重新帮我做一个新的了，再次多谢！

YZC51

ysjjess 发表于 2020-1-14 16:25
谢谢你！本来上次是你帮我改了好多，但就二个问题没实现，看来还是只有麻烦你重新帮我做一个新的了，再次 ...

不客气！请详细介绍下