Excel VBA/MySQL实现部门转置、多供应商分组合并技术问询

针对你要将原始表（BEFORE）转换为目标表（AFTER）的需求，我会分别从VBA完整实现和MySQL查询优化两个维度给出解决方案，覆盖你提到的两个核心要求：

一、MySQL查询优化与完整实现 #

你的原始SQL存在几个问题：GROUP BY字段不匹配SELECT列表、ORDER BY拼写错误、未去重vendor、WHERE条件过于固化。以下是优化后的通用版本：

优化后的基础分组查询代码 #

SELECT 
  location,
  office,
  department,
  GROUP_CONCAT(DISTINCT vendor ORDER BY vendor SEPARATOR ', ') AS vendor_list
FROM `tbl_dep_ven_location`
-- 如需筛选特定条件可保留WHERE，否则移除
-- WHERE location = 'Femty' AND department = 'Procurement'
GROUP BY location, office, department  -- 必须包含所有非聚合字段
ORDER BY location, office, department;

关键优化点说明 #

• GROUP BY规范：严格遵循SQL模式要求，GROUP BY需包含SELECT中所有非聚合函数的字段（location、office、department），避免潜在的分组逻辑错误
• 去重与排序：在GROUP_CONCAT中加入DISTINCT确保vendor唯一，同时ORDER BY vendor让结果更整洁
• 灵活筛选：保留可选的WHERE子句，方便按需过滤特定location或department
• 字段命名：将vendor改为vendor_list更清晰，避免与原字段混淆

动态交叉表实现（部门转为列） #

如果需要直接生成交叉表格式（把唯一部门转为表头列），可以使用MySQL的动态SQL自动适配所有部门：

SET @sql = NULL;
SELECT
  GROUP_CONCAT(DISTINCT
    CONCAT(
      'MAX(CASE WHEN department = ''',
      department,
      ''' THEN vendor_list END) AS `',
      department,
      '`'
    )
  ) INTO @sql
FROM tbl_dep_ven_location;

SET @sql = CONCAT(
  'SELECT location, office, ', @sql, ' 
   FROM (
     SELECT location, office, department, 
            GROUP_CONCAT(DISTINCT vendor ORDER BY vendor SEPARATOR ', ') AS vendor_list
     FROM tbl_dep_ven_location
     GROUP BY location, office, department
   ) AS temp
   GROUP BY location, office
   ORDER BY location, office;'
);

PREPARE stmt FROM @sql;
EXECUTE stmt;
DEALLOCATE PREPARE stmt;

这段代码会自动识别所有唯一部门并转为列，填充对应分组的vendor列表。

二、VBA完整实现方案 #

你的现有VBA仅完成了部门的排序转置，以下是覆盖全部需求的完整代码，包含唯一部门提取、分组聚合vendor、交叉表生成：

完整VBA代码 #

Sub TransformDepVenData()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim depDict As Object, vendorDict As Object
    Dim i As Long, j As Long
    Dim loc As String, off As String, dep As String, ven As String
    Dim key As Variant
    
    ' 设置源表和目标表（可根据实际修改）
    Set wsSource = ThisWorkbook.Worksheets("BEFORE")
    Set wsTarget = ThisWorkbook.Worksheets.Add(After:=wsSource)
    wsTarget.Name = "AFTER"
    
    ' 初始化字典存储唯一部门和分组数据
    Set depDict = CreateObject("Scripting.Dictionary")
    Set vendorDict = CreateObject("Scripting.Dictionary")
    
    ' 1. 遍历源数据，收集唯一部门和分组vendor
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow ' 假设第1行是表头
        loc = Trim(wsSource.Cells(i, "A").Value) ' location列，假设是A列
        off = Trim(wsSource.Cells(i, "B").Value) ' office列，假设是B列
        dep = Trim(wsSource.Cells(i, "D").Value) ' department列，假设是D列
        ven = Trim(wsSource.Cells(i, "C").Value) ' vendor列，假设是C列
        
        ' 记录唯一部门
        If Not depDict.Exists(dep) Then
            depDict(dep) = True
        End If
        
        ' 构建分组键：location|office|department
        key = loc & "|" & off & "|" & dep
        ' 收集唯一vendor（利用Collection的Key属性去重）
        If Not vendorDict.Exists(key) Then
            Set vendorDict(key) = New Collection
        End If
        On Error Resume Next ' 避免重复添加时报错
        vendorDict(key).Add ven, Key:=ven
        On Error GoTo 0
    Next i
    
    ' 2. 转置唯一部门为目标表表头
    wsTarget.Cells(1, 1).Value = "Location"
    wsTarget.Cells(1, 2).Value = "Office"
    j = 3
    For Each key In depDict.Keys
        wsTarget.Cells(1, j).Value = key
        j = j + 1
    Next key
    
    ' 3. 填充分组后的vendor数据
    Dim groupArr As Variant
    Dim rowNum As Long: rowNum = 2
    ' 遍历所有分组键，拆分location、office、department
    For Each key In vendorDict.Keys
        groupArr = Split(key, "|")
        loc = groupArr(0)
        off = groupArr(1)
        dep = groupArr(2)
        
        ' 填充location和office
        wsTarget.Cells(rowNum, 1).Value = loc
        wsTarget.Cells(rowNum, 2).Value = off
        
        ' 查找对应的部门列，填充vendor列表
        lastCol = wsTarget.Cells(1, wsTarget.Columns.Count).End(xlToLeft).Column
        For j = 3 To lastCol
            If wsTarget.Cells(1, j).Value = dep Then
                ' 将Collection转为逗号分隔字符串
                Dim venStr As String
                venStr = ""
                For Each ven In vendorDict(key)
                    venStr = venStr & ", " & ven
                Next ven
                wsTarget.Cells(rowNum, j).Value = Mid(venStr, 3) ' 移除开头的", "
                Exit For
            End If
        Next j
        
        rowNum = rowNum + 1
    Next key
    
    ' 4. 格式化目标表
    wsTarget.UsedRange.AutoFit
    wsTarget.Rows(1).Font.Bold = True
    
    MsgBox "数据转换完成！", vbInformation
End Sub

关键优化与说明 #

• 高效去重：用Scripting.Dictionary存储唯一部门和分组键，用Collection的Key特性自动去重vendor，避免重复值
• 灵活适配：代码中假设的列位置（A=location、B=office、C=vendor、D=department）可根据你的实际表结构修改
• 自动格式：完成转换后自动调整列宽、加粗表头，提升可读性
• 错误处理：添加On Error Resume Next避免重复添加vendor时的报错

三、选择建议 #

• 如果数据存储在数据库中，优先使用MySQL方案，处理大数据量更高效，且支持动态生成交叉表
• 如果数据在Excel中且需要手动操作，使用VBA方案，一键完成转换，无需依赖数据库

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