基于供应商编号自动生成唯一产品列表的VBA代码需求

实现步骤 #

1. 打开Excel，按下Alt+F11打开VBA编辑器
2. 在左侧「工程资源管理器」窗口（未显示则按Ctrl+R调出），双击Sheet2打开其代码窗口
3. 将以下代码粘贴到代码窗口中
4. 保存工作簿为**Excel 启用宏的工作簿（.xlsm）**格式

VBA代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅响应Sheet2中B1单元格的内容变化
    If Target.Address <> "$B$1" Then Exit Sub
    
    Dim sourceSheet As Worksheet
    Dim destSheet As Worksheet
    Dim lastDataRow As Long
    Dim rowIndex As Long
    Dim selectedSupplier As String
    Dim uniqueProducts As Object
    
    ' 指定数据源表和结果表
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set destSheet = ThisWorkbook.Sheets("Sheet2")
    ' 创建字典用于存储唯一产品（自动去重）
    Set uniqueProducts = CreateObject("Scripting.Dictionary")
    
    ' 清空之前生成的产品列表（B15及以下区域）
    destSheet.Range("B15:B" & destSheet.Cells(destSheet.Rows.Count, "B").End(xlUp).Row).ClearContents
    
    ' 获取选中的供应商编号，若为空则直接退出
    selectedSupplier = destSheet.Range("B1").Value
    If selectedSupplier = "" Then Exit Sub
    
    ' 找到Sheet1中供应商编号列（D列）的最后一行数据
    lastDataRow = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
    
    ' 遍历Sheet1数据，匹配供应商并收集唯一产品
    ' 假设Sheet1第一行是表头，数据从第二行开始，若数据从第一行开始则把2改成1
    For rowIndex = 2 To lastDataRow
        If sourceSheet.Cells(rowIndex, "D").Value = selectedSupplier Then
            Dim product As String
            product = sourceSheet.Cells(rowIndex, "N").Value
            ' 仅添加未在字典中出现过的产品
            If Not uniqueProducts.Exists(product) Then
                uniqueProducts.Add product, product
            End If
        End If
    Next rowIndex
    
    ' 将收集到的唯一产品写入Sheet2的B15起始位置
    If uniqueProducts.Count > 0 Then
        destSheet.Range("B15").Resize(uniqueProducts.Count, 1).Value = Application.WorksheetFunction.Transpose(uniqueProducts.Keys)
    End If
End Sub

注意事项 #

• 如果Sheet1没有表头（第一行就是数据），请将代码中For rowIndex = 2 To lastDataRow的2改为1
• 每次在Sheet2的B1选择新供应商编号，旧的产品列表会自动清空并生成新的唯一列表
• 若打开文件时宏被禁用，需在Excel的「文件>选项>信任中心>信任中心设置>宏设置」中启用宏（仅打开你信任的文件）

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