Excel 2019下拉框VBA代码适配及部署问题技术咨询

环境 #

Excel 2019 32位专业版桌面版

问题1：源数据修改后下拉框保留无效值 #

解决方案 #

在源工作表添加变更事件，当源数据修改时自动校验目标工作表的现有值，清理无效内容；同时优化目标工作表的激活逻辑：

1. 在三个源工作表（Angles for estimation、Categories for estimation、Fundamentals for estimation）中分别添加以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim monitorRange As Range
    Select Case Me.Name
        Case "Angles for estimation"
            Set monitorRange = Me.Range("$A$8:$A$1008")
        Case "Categories for estimation"
            Set monitorRange = Me.Range("$A$8:$A$1008")
        Case "Fundamentals for estimation"
            Set monitorRange = Me.Range("$A$8:$A$22")
    End Select
    
    If Not Intersect(Target, monitorRange) Is Nothing Then
        Call UpdateDropDownsAndValidateValues
    End If
End Sub

2. 在DropDownOP模块新增校验逻辑：

Sub UpdateDropDownsAndValidateValues()
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets(DropDownsSheetName)
    
    SetDropDownList
    ValidateRangeValues wsTarget.Range(DropDownsRangeName), Range(DropDownsSourceRangeName)
    ValidateRangeValues wsTarget.Range(DropDownsRangeName2), Range(DropDownsSourceRangeName2)
    ValidateRangeValues wsTarget.Range(DropDownsRangeName3), Range(DropDownsSourceRangeName3)
End Sub

Sub ValidateRangeValues(targetRng As Range, sourceRng As Range)
    Dim sourceValues As Variant
    sourceValues = GetNonEmptyValues(sourceRng)
    
    Dim cell As Range
    For Each cell In targetRng
        If cell.Value <> "" And IsError(Application.Match(cell.Value, sourceValues, 0)) Then
            Application.EnableEvents = False
            cell.Value = ""
            Application.EnableEvents = True
        End If
    Next cell
End Sub

Function GetNonEmptyValues(rng As Range) As Variant
    Dim arr() As Variant, count As Long
    count = 0
    ReDim arr(1 To rng.Cells.Count)
    
    For Each cell In rng
        If cell.Value <> "" Then
            count = count + 1
            arr(count) = cell.Value
        End If
    Next cell
    
    ReDim Preserve arr(1 To count)
    GetNonEmptyValues = arr
End Function

问题2：Formula1字符限制与命名范围空行问题 #

解决方案 #

改用动态命名范围，自动仅包含源区域非空单元格，直接作为下拉框数据源，彻底规避字符限制和空行：

1. 修改AddNamedRangeAndSetDropDown中的命名范围定义：

Sub AddNamedRangeAndSetDropDown()
    DeleteNamedRanges
    
    ' 动态命名范围：自动适配非空单元格数量
    ThisWorkbook.Names.Add _
        Name:=DropDownsSourceRangeName, _
        RefersTo:="=OFFSET('" & DropDownsSourceSheetName & "'!$A$8,0,0,COUNTA('" & DropDownsSourceSheetName & "'!$A$8:$A$1008),1)"
    ThisWorkbook.Names.Add _
        Name:=DropDownsRangeName, _
        RefersTo:="='" & DropDownsSheetName & "'!" & DropDownsRangeAddress
        
    ThisWorkbook.Names.Add _
        Name:=DropDownsSourceRangeName2, _
        RefersTo:="=OFFSET('" & DropDownsSourceSheetName2 & "'!$A$8,0,0,COUNTA('" & DropDownsSourceSheetName2 & "'!$A$8:$A$1008),1)"
    ThisWorkbook.Names.Add _
        Name:=DropDownsRangeName2, _
        RefersTo:="='" & DropDownsSheetName & "'!" & DropDownsRange2Address
        
    ThisWorkbook.Names.Add _
        Name:=DropDownsSourceRangeName3, _
        RefersTo:="=OFFSET('" & DropDownsSourceSheetName3 & "'!$A$8,0,0,COUNTA('" & DropDownsSourceSheetName3 & "'!$A$8:$A$22),1)"
    ThisWorkbook.Names.Add _
        Name:=DropDownsRangeName3, _
        RefersTo:="='" & DropDownsSheetName & "'!" & DropDownsRange3Address
    
    SetDropDownList
End Sub

2. 修改SetDropDownList，直接引用动态命名范围，删除getFormula1函数：

Sub SetDropDownList()
   Dim rngDropDown As Range, arrDrD(), arrSource(), arrAngle(), i As Long
   
   arrDrD = Array(DropDownsRangeName, DropDownsRangeName2, DropDownsRangeName3)
   arrSource = Array(DropDownsSourceRangeName, DropDownsSourceRangeName2, DropDownsSourceRangeName3)
   arrAngle = Array("Angle", "Angle1", "Angle2")
   
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   
   For i = 0 To UBound(arrDrD)
      Set rngDropDown = Sheets(DropDownsSheetName).Range(arrDrD(i))
      
      With rngDropDown.Validation
          .Delete
          .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                        Operator:=xlBetween, _
                        Formula1:="=" & arrSource(i)
          .IgnoreBlank = True
          .InCellDropdown = True
          .InputTitle = vbNullString
          .ErrorTitle = "Invalid value"
          .InputMessage = arrAngle(i)
          .ErrorMessage = "Select a valid value in the list."
          .ShowInput = True
          .ShowError = True
       End With
    Next i
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

问题3：主工作簿部署操作顺序 #

正确步骤（避免代码误触发） #

1. 禁用事件：打开主工作簿，按Alt+F11进入VBA编辑器，在立即窗口输入Application.EnableEvents = False回车。
2. 复制工作表：将三个源工作表和Fundfakt-kateg-vinkl工作表从高版本工作簿复制到主工作簿。
3. 修改工作表结构：在Fundfakt-kateg-vinkl中添加所需列。
4. 配置命名范围：运行修改后的AddNamedRangeAndSetDropDown宏，生成动态命名范围。
5. 替换VBA代码：
   • 删除Fundfakt-kateg-vinkl中原有的工作表代码；
   • 导入修改后的DropDownOP模块代码；
   • 在三个源工作表中添加问题1中的变更事件代码。
6. 恢复事件：在立即窗口输入Application.EnableEvents = True回车。
7. 测试验证：切换工作表、修改源数据，确认功能正常。

问题4：切换工作表卡顿与1004错误 #

解决方案 #

1. 优化激活事件：避免每次激活都重建所有资源，仅在必要时执行初始化：

Private Sub Worksheet_Activate()
    On Error Resume Next
    Dim testName As Name
    Set testName = ThisWorkbook.Names(DropDownsSourceRangeName)
    On Error GoTo 0
    
    If testName Is Nothing Then
        Application.ScreenUpdating = False
        AddNamedRangeAndSetDropDown
        Application.ScreenUpdating = True
    End If
End Sub

2. 添加性能开关：在耗时宏中禁用屏幕更新、事件和自动计算：

Sub AddNamedRangeAndSetDropDown()
    Dim calcMode As XlCalculation
    calcMode = Application.Calculation
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    DeleteNamedRanges
    ' 动态命名范围创建代码...
    SetDropDownList
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = calcMode
End Sub

3. 排查1004错误：检查动态命名范围公式，确保工作表名称无特殊字符（需用单引号包裹），确认源区域存在且路径正确。

内容的提问来源于stack exchange，提问作者Unicorn