[已解决]如何实现录入编码就会显示编码及名称的问题？

爱疯

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 And Target.Count = 1 Then
        Application.EnableEvents = False
        Target = matchSubject(Target.Text)
        Application.EnableEvents = True
    End If
End Sub

'匹配科目
Function matchSubject(val As String) As String
    Dim arr, dic, i%, str$
    arr = Range("i2:i" & Range("i65536").End(xlUp).Row)
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        If arr(i, 1) Like "[[]*[]]*" Then
            str = VBA.Split(arr(i, 1), "]")(0)
            str = VBA.Split(str, "[")(1)
            dic(str) = arr(i, 1)
        End If
    Next i
    matchSubject = IIf(dic.exists(val), dic(val), "自定义错误信息")    '自行修改文字内容
End Function

Book3.rar (14.67 KB, 下载次数: 8)

2016-5-10 09:45 上传

点击文件名下载附件



自行修改颜色部分的文字。

zhqsl

爱疯 发表于 2016-5-10 09:46
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 And Target.Count = 1 T ...

楼主真牛！谢谢了！

zhqsl

爱疯 发表于 2016-5-10 09:46
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 And Target.Count = 1 T ...

又发现新问题了，录入科目，又删除后，总显示那个自定义文字信息，用键盘上的删除键不能删除，还得右键清除。

02761752696

zhqsl 发表于 2016-5-10 13:37
又发现新问题了，录入科目，又删除后，总显示那个自定义文字信息，用键盘上的删除键不能删除，还得右键清 ...

加一句代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target = "" Then Exit Sub

复制代码

爱疯

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 And Target.Count = 1 And Target <> "" Then
        Application.EnableEvents = False
        Target = matchSubject(Target.Text)
        Application.EnableEvents = True
    End If
End Sub

'匹配科目
Function matchSubject(val As String) As String
    Dim arr, dic, i%, str$
    arr = Range("i2:i" & Range("i65536").End(xlUp).Row)
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        If arr(i, 1) Like "[[]*[]]*" Then
            str = VBA.Split(arr(i, 1), "]")(0)
            str = VBA.Split(str, "[")(1)
            dic(str) = arr(i, 1)
        End If
    Next i
    matchSubject = IIf(dic.exists(val), dic(val), "自定义错误信息")    '自行修改文字内容
End Function


Book4.rar (14.6 KB, 下载次数: 7)

2016-5-10 14:52 上传

点击文件名下载附件



确实是一个疏漏，蓝色是修改过的

zhqsl

感谢02761752696和爱疯的精彩解答。一个一个删除可以了，右键一个一个清除也可以，但是同时选中两个及以上右键清除的话，还是报错。不好意思，我想劲量完美些！

爱疯

Book5.rar (14.51 KB, 下载次数: 11)

2016-5-10 20:50 上传

点击文件名下载附件