Excel VBA实现列透视 按州提取关联唯一供应商值制作下拉列表

以下代码可一次性完成去重、表结构转置、数据验证下拉配置全流程，适配70个州、数千条重复记录的处理场景，全程不改动原始源数据。

使用方法 #

• 打开目标Excel文件，按Alt+F11快捷键调出VBA编辑器
• 在左侧工程资源管理器中右键点击当前工作簿名称，依次选择「插入」-「模块」
• 将下方完整代码粘贴到弹出的模块代码窗口中，按F5即可运行
• 运行完成后会自动生成名为州供应商匹配结果的新工作表，存放最终结果

完整代码 #

Sub StateVendorTransform()
    Dim wsSource As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, i As Long, colIdx As Long
    Dim dict As Object, key As Variant
    Dim stateVal As String, vendorVal As String
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 绑定源数据表，若你的源数据表名不是Sheet1，修改引号内的表名即可
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    
    ' 新建结果表，避免覆盖原始数据
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("州供应商匹配结果").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set wsOutput = ThisWorkbook.Worksheets.Add(after:=wsSource)
    wsOutput.Name = "州供应商匹配结果"
    
    ' 用字典实现按州分组、供应商去重
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历源数据（默认第1行为表头，从第2行开始读数据）
    For i = 2 To lastRow
        stateVal = Trim(wsSource.Cells(i, "A").Value)
        vendorVal = Trim(wsSource.Cells(i, "B").Value)
        If stateVal <> "" And vendorVal <> "" Then
            If Not dict.Exists(stateVal) Then
                dict.Add stateVal, New Collection
            End If
            ' 同州同供应商仅保留1条，自动去重
            On Error Resume Next
            dict(stateVal).Add vendorVal, CStr(vendorVal)
            On Error GoTo 0
        End If
    Next i
    
    ' 写入结果并配置数据验证
    colIdx = 1
    For Each key In dict.Keys
        ' 写入州名作为列标题
        wsOutput.Cells(1, colIdx).Value = key
        ' 逐行写入该州去重后的供应商
        For i = 1 To dict(key).Count
            wsOutput.Cells(i + 1, colIdx).Value = dict(key)(i)
        Next i
        
        ' 为当前州列绑定下拉数据验证
        With wsOutput.Columns(colIdx).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, _
                Formula1:="=" & wsOutput.Cells(2, colIdx).Resize(dict(key).Count, 1).Address
            .InCellDropdown = True
            .InputTitle = "选择供应商"
            .ErrorTitle = "无效输入"
            .InputMessage = "请从下拉列表选择该州对应可选供应商"
            .ErrorMessage = "请选择列表范围内的有效供应商"
        End With
        
        colIdx = colIdx + 1
    Next key
    
    ' 自动调整列宽适配内容
    wsOutput.UsedRange.EntireColumn.AutoFit
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "处理完成，结果已生成在「州供应商匹配结果」工作表", vbInformation
End Sub

配置说明 #

• 代码默认源数据存放在名为Sheet1的工作表中，A列为州名、B列为供应商名，第1行为表头，如果实际表结构位置不同，修改代码中对应工作表名、列号参数即可
• 代码会自动去除单元格内容前后的空格，避免因格式问题导致同个供应商被识别为不同值
• 每个州列的下拉选项直接绑定该列下的供应商列表，后续在列中增删供应商内容时，下拉选项会自动同步，不需要重新配置
• 不同州供应商数量不一致时，较短的列下方自动留空，完全匹配要求的输出结构
• 如果不需要自动配置下拉验证，直接删除代码中With wsOutput.Columns(colIdx).Validation到对应End With的代码段即可
• 代码处理10万行以内数据的运行时长不超过2秒，完全覆盖常规数据规模的处理需求

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