请大师帮忙再看下下拉列表的问题

雷雷爸

各位大神好，我这边有张工作表，D E F列下拉列表去重已解决，就是鼠标光标有点抖，后面还有几列内容下拉列表来自数据源表中，不需要去重，请问各位老师能否用VBA的方法解决，出错警告的要勾选上，如果下拉列表的内容能够按照内容第一个字的首字母升序就好了，“生产日志“”工作表第三行用的VLOOKUP函数根据序号查找的下方函数，也可以用VBA解决吗？谢谢各位老师

蓝桥玄霜

出错警告Target.Validation.ShowError = False改为：
Target.Validation.ShowError = True
除DEF列以外的列的数据有效性用VBA来实现，当然也是可以的。在本论坛搜索”数据有效性“，应该有大把的实例可供参考。

1121228509

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim hh As Long, lh As Long
On Error Resume Next
Application.EnableEvents = False
If Target.CountLarge = 1 And Target.Address = "$A$3" Then
    Dim Arr(1 To 1, 2 To 39) As Variant
    hh = Application.Match(Range("A3"), Range("A5").Resize(Cells(Rows.Count, 1).End(xlUp).Row, 1)) + 4
    For lh = 2 To 39
        Arr(1, lh) = Cells(hh, lh).Value
    Next lh
    Range("B3:AL3") = Arr
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim hh As Long, lh As Long, fk As Long, xh As Long
Dim dic As Object
Dim Arr As Variant
Dim Z As String
On Error Resume Next
Application.EnableEvents = False
hh = Target.Row
lh = Target.Column
fk = Sheets("生产日志").Cells(Rows.Count, 1).End(xlUp).Row
Set dic = CreateObject("scripting.dictionary")
If (Target.CountLarge = 1 And hh > 4 And hh <= fk And lh < 11) Or Target.Address = "$A$3" Then
    If lh = 3 Then
        fk = Sheets("数据源").Cells(Rows.Count, 1).End(xlUp).Row
        Arr = Sheets("数据源").Range("N2").Resize(fk, 1)
        ReDim Brr(0 To fk) As Variant
        For xh = 1 To fk
            If (Not dic.Exists(Arr(xh, 1))) And Arr(xh, 1) <> "" Then
                dic.Add Arr(xh, 1), ""
                Brr(xh) = Arr(xh, 1)
            End If
        Next xh
        If VarType(Brr(1)) = vbDate Then
            Range("C5").Resize(fk, 1).Validation.Delete
            Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(Brr, ",")
            Target.Validation.IgnoreBlank = True
            Target.Validation.InCellDropdown = True
            Target.Validation.ErrorTitle = "无效的列外日期"
            Target.Validation.ErrorMessage = "不允许输入列外日期"
            Target.Validation.IMEMode = xlIMEModeNoControl
            Target.Validation.ShowInput = False
            Target.Validation.ShowError = True
            Target.Locked = False
        End If
        Erase Brr
    Else
        If Target.CountLarge = 1 And Target.Address = "$A$3" Then
            fk = Cells(Rows.Count, lh).End(xlUp).Row
            Arr = Cells(5, lh).Resize(fk, 1)
            For xh = 1 To fk
                If (Not dic.Exists(Arr(xh, 1))) And Arr(xh, 1) <> "" Then dic.Add Arr(xh, 1), ""
            Next xh
         Else
            If lh > 3 And lh < 7 Then
                fk = Cells(Rows.Count, lh).End(xlUp).Row
                Arr = Cells(5, lh).Resize(fk, 1)
                For xh = 1 To fk
                    If (Not dic.Exists(Arr(xh, 1))) And Arr(xh, 1) <> "" Then dic.Add Arr(xh, 1), ""
                Next xh
            Else
                If lh > 6 And lh < 11 Then
                    lh = lh - 6
                    fk = Sheets("数据源").Cells(Rows.Count, lh).End(xlUp).Row
                    Arr = Sheets("数据源").Cells(2, lh).Resize(fk, 1)
                    For xh = 1 To fk
                        If (Not dic.Exists(Arr(xh, 1))) And Arr(xh, 1) <> "" Then
                            If lh + 6 = 9 Then
                                dic.Add Format(Arr(xh, 1), "0%"), ""
                            Else
                                dic.Add Arr(xh, 1), ""
                            End If
                        End If
                    Next xh
                End If
            End If
        End If
        If dic.Count <> 0 Then
            fk = Sheets("生产日志").Cells(Rows.Count, 1).End(xlUp).Row
            Range("A3").Validation.Delete
            Range("D5").Resize(fk, 7).Validation.Delete
            Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(dic.Keys, ",")
            Target.Validation.IgnoreBlank = True
            Target.Validation.InCellDropdown = True
            Target.Validation.ErrorTitle = "无效的列外名称"
            Target.Validation.ErrorMessage = "不允许输入列外名称"
            Target.Validation.IMEMode = xlIMEModeNoControl
            Target.Validation.ShowInput = False
            Target.Validation.ShowError = True
            Target.Locked = False
        End If
    End If
End If
Set Arr = Nothing
Set dic = Nothing
Application.EnableEvents = True
End Sub
生产日志.rar (90.1 KB, 下载次数: 6)

2023-6-6 23:42 上传

点击文件名下载附件

雷雷爸

1121228509 发表于 2023-6-6 23:42
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim hh As Long, lh As Long

很感谢老师，可能我有些地方表述的不是太清楚，C D E F四列需要能手动修改，其他下拉列表限制修改，已经很好了，谢谢，麻烦老师了

1121228509

雷雷爸 发表于 2023-6-7 12:04
很感谢老师，可能我有些地方表述的不是太清楚，C D E F四列需要能手动修改，其他下拉列表限制修改，已经 ...

是根据A列序号向下扩展生成有效性序列

1121228509

上面附件代码有错误下载这个附件
生产日志1.rar (37.47 KB, 下载次数: 0)

2023-6-8 00:55 上传

点击文件名下载附件