请求帮助：将MySQL动态透视表代码转为Excel宏并补全用户ID循环

原MySQL实现逻辑 #

这段SQL的作用是动态生成透视表：提取report表中所有唯一的question作为列，把每个用户对应的response填充到对应列，最终按userId分组输出用户基础信息+各问题的回答。

SET @pivot_sql = NULL;

SELECT GROUP_CONCAT(DISTINCT 
                    CONCAT('GROUP_CONCAT(CASE WHEN question= "', `question`, '" THEN response ELSE NULL END) AS "', `question`, '"')
) 
INTO @pivot_sql
FROM 
    report;
    
SET @pivot_sql = CONCAT('SELECT firstname as firstname, lastname as lastname, supervisorname as supervisor, role as role, department AS department, userId, ', @pivot_sql,' FROM report GROUP BY userId');

PREPARE stmt FROM @pivot_sql;
EXECUTE stmt;
DEALLOCATE PREPARE stmt;

需求说明 #

需要把上述逻辑迁移到Excel VBA中：

• 数据源来自Excel的Data工作表（对应原SQL的report表）
• 最终生成FinalReport工作表，包含用户基础信息列，以及所有唯一问题作为列，填充每个用户对应的回答

现有VBA代码（已完成列创建，缺数据填充） #

Sub CreateNewSheetWithUniqueValues()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim uniqueValues As Object
    Dim value As Variant

    ' 定义存储数据的Excel工作表
    Set ws = ThisWorkbook.Sheets("Data") ' 将"Data"替换为你的工作表名称

    ' 创建字典存储唯一值
    Set uniqueValues = CreateObject("Scripting.Dictionary")

    ' 查找"Data"工作表的最后一行数据
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' 收集"Question"列的唯一值
    For i = 2 To lastRow ' 假设数据从第2行开始
        uniqueValues(ws.Cells(i, 7).value) = 1 ' 假设"Question"列是第7列，可按需修改
    Next i

    ' 创建存储唯一值的新工作表
    Set newWs = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    newWs.Name = "FinalReport" ' 替换为你想要的工作表名称

    ' 在新工作表中写入唯一值作为列
    
    newWs.Cells(1, 1).value = "id"
    newWs.Cells(1, 2).value = "FirstName"
    newWs.Cells(1, 3).value = "lastName"
    newWs.Cells(1, 4).value = "Department"
    newWs.Cells(1, 5).value = "Role"
    newWs.Cells(1, 6).value = "Supervisor"
    j = 7
    For Each value In uniqueValues.Keys
        newWs.Cells(1, j).value = value
        j = j + 1
    Next value
    
    ' 遍历新工作表中的"Answers"列（待补全逻辑）
  
End Sub

补全数据填充逻辑后的完整VBA代码 #

通过两个字典分别记录用户行映射和问题列映射，实现按用户ID分组填充数据：

Sub CreateNewSheetWithUniqueValues()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim lastRow As Long
    Dim i As Long, newRow As Long
    Dim questionColMap As Object, userRowMap As Object
    Dim userId As String, question As String, response As String
    Dim baseCols As Variant

    ' 定义基础列名称（对应原SQL的用户信息列）
    baseCols = Array("id", "FirstName", "lastName", "Department", "Role", "Supervisor")
    
    ' 绑定数据源工作表
    Set ws = ThisWorkbook.Sheets("Data")
    ' 创建两个字典：存储问题-列号映射、用户ID-新表行号映射
    Set questionColMap = CreateObject("Scripting.Dictionary")
    Set userRowMap = CreateObject("Scripting.Dictionary")
    
    ' 获取数据源最后一行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' 第一步：收集所有唯一问题并建立列映射
    For i = 2 To lastRow
        question = ws.Cells(i, 7).Value ' 假设Question在第7列，按需修改
        If Not questionColMap.Exists(question) Then
            questionColMap(question) = questionColMap.Count + UBound(baseCols) + 2 ' 基础列占6列，从第7列开始
        End If
    Next i

    ' 创建结果工作表并写入表头
    Set newWs = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    newWs.Name = "FinalReport"
    ' 写入基础信息表头
    For i = 0 To UBound(baseCols)
        newWs.Cells(1, i + 1).Value = baseCols(i)
    Next i
    ' 写入问题表头
    For Each question In questionColMap.Keys
        newWs.Cells(1, questionColMap(question)).Value = question
    Next question

    ' 第二步：遍历数据源，填充用户信息和对应回答
    newRow = 2 ' 新表数据从第2行开始
    For i = 2 To lastRow
        userId = ws.Cells(i, 6).Value ' 假设UserID在第6列，按需修改
        ' 如果用户未在新表中，先写入基础信息
        If Not userRowMap.Exists(userId) Then
            userRowMap(userId) = newRow
            ' 复制用户基础信息（需根据你的实际列位置调整）
            newWs.Cells(newRow, 1).Value = ws.Cells(i, 1).Value ' ID
            newWs.Cells(newRow, 2).Value = ws.Cells(i, 2).Value ' FirstName
            newWs.Cells(newRow, 3).Value = ws.Cells(i, 3).Value ' lastName
            newWs.Cells(newRow, 4).Value = ws.Cells(i, 4).Value ' Department
            newWs.Cells(newRow, 5).Value = ws.Cells(i, 5).Value ' Role
            newWs.Cells(newRow, 6).Value = ws.Cells(i, 8).Value ' Supervisor（假设在第8列）
            newRow = newRow + 1
        End If
        ' 填充当前问题的回答
        question = ws.Cells(i, 7).Value
        response = ws.Cells(i, 9).Value ' 假设Response在第9列，按需修改
        newWs.Cells(userRowMap(userId), questionColMap(question)).Value = response
    Next i

    ' 自动调整列宽优化显示
    newWs.UsedRange.Columns.AutoFit
End Sub

关键逻辑说明 #

• questionColMap：记录每个问题对应的结果表列号，避免重复查找列位置
• userRowMap：记录每个用户ID对应的结果表行号，确保同一用户的基础信息只写入一次
• 代码中标记的列位置（如Question在第7列）需根据你的实际数据源结构修改

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