基于双下拉框条件生成动态唯一产品列表的VBA代码优化需求

需求说明 #

• 工作表结构：
  • Sheet2（Written Reports）：D列=供应商编号，E列=品牌，K列=类别，N列=产品描述
  • Sheet1（Supplier Overview Report）：B1为供应商名称下拉框，C1自动返回对应供应商编号；B2为类别下拉框，C2自动返回对应类别代码
• 优化目标：
  • 触发条件改为B1下拉框变更（原代码监听E1）
  • 新增C2类别条件筛选，生成同时符合**供应商编号（C1）和类别代码（C2）**的唯一产品列表，从Sheet1的A18开始输出
  • 操作逻辑简化，适配非计算机熟练人员

现有VBA代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Address = "$E$1" And Len(.Cells(1).Value) > 0 Then
            Dim objDic As Object, rngData As Range
            Dim i As Long, sKey As String, sSupp As String
            Dim lastRow As Long, arrData
            Dim oSht1 As Worksheet
            Set oSht1 = Sheets("Written Reports")
            sSupp = .Value
            lastRow = oSht1.Cells(oSht1.Rows.Count, "N").End(xlUp).Row
            Set rngData = oSht1.Range("D1:N" & lastRow)
            arrData = rngData.Value
            Set objDic = CreateObject("scripting.dictionary")
            For i = LBound(arrData) To UBound(arrData)
                sKey = arrData(i, 1) ' Col D [Supplier]
                If StrComp(sSupp, sKey, vbTextCompare) = 0 Then
                    objDic(arrData(i, 11)) = ""
                End If
            Next i
            ' Write Product list to sheet
            lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
            Application.EnableEvents = False
            If lastRow > 16 Then Me.Range("A17:A" & lastRow).ClearContents
            If objDic.Count > 0 Then Me.Range("A17").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
            Application.EnableEvents = True
        End If
    End With
End Sub

优化后VBA代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 监听B1（供应商下拉框）或B2（类别下拉框）的变更
    If Not Intersect(Target, Me.Range("B1:B2")) Is Nothing Then
        Dim objDic As Object, rngData As Range
        Dim i As Long, suppID As String, categoryCode As String
        Dim lastRow As Long, arrData
        Dim dataSht As Worksheet
        
        ' 获取筛选条件：C1的供应商编号、C2的类别代码
        suppID = Trim(Me.Range("C1").Value)
        categoryCode = Trim(Me.Range("C2").Value)
        
        ' 若未选择供应商，直接清空列表并退出
        If suppID = "" Then
            Application.EnableEvents = False
            Me.Range("A18:A" & Me.Cells(Me.Rows.Count, "A").End(xlUp).Row).ClearContents
            Application.EnableEvents = True
            Exit Sub
        End If
        
        Set dataSht = Sheets("Written Reports")
        ' 以D列（供应商编号）为准获取数据最后一行，避免N列无数据的情况
        lastRow = dataSht.Cells(dataSht.Rows.Count, "D").End(xlUp).Row
        ' 加载数据到数组，提升遍历效率
        arrData = dataSht.Range("D1:N" & lastRow).Value
        
        Set objDic = CreateObject("scripting.dictionary")
        objDic.CompareMode = vbTextCompare ' 忽略大小写匹配
        
        ' 遍历数据筛选符合条件的唯一产品
        For i = LBound(arrData) To UBound(arrData)
            ' 匹配供应商编号，类别代码为空则忽略类别条件
            If StrComp(arrData(i, 1), suppID, vbTextCompare) = 0 Then
                If categoryCode = "" Or StrComp(arrData(i, 8), categoryCode, vbTextCompare) = 0 Then
                    ' arrData(i,11)对应N列产品描述，添加到字典去重
                    objDic(arrData(i, 11)) = ""
                End If
            End If
        Next i
        
        ' 写入筛选结果到Sheet1
        Application.EnableEvents = False
        ' 清空A18及以下的旧数据
        Me.Range("A18:A" & Me.Cells(Me.Rows.Count, "A").End(xlUp).Row).ClearContents
        ' 有结果则写入单元格
        If objDic.Count > 0 Then
            Me.Range("A18").Resize(objDic.Count, 1) = Application.Transpose(objDic.keys)
        End If
        Application.EnableEvents = True
    End If
End Sub

优化说明 #

• 触发逻辑调整：监听B1/B2的变更，用户选择下拉框后自动触发筛选，无需手动输入编号
• 多条件筛选：同时匹配供应商和类别，类别未选择时自动忽略该条件
• 操作友好性：未选择供应商时自动清空列表，全程无额外操作，适配非专业人员
• 性能与稳定性：
  • 用数组遍历替代单元格操作，提升运行速度
  • 字典设置忽略大小写，避免大小写差异导致的匹配错误
  • 清空数据时保留A17及以上的表头，避免误删

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