Excel 宏中的动态透视数据-解网

问：

我想知道如何将此MySQL代码转换为Excel Macro。如果 Excel 宏中的数据将来自 excel Sheet1 而不是数据库。

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;

下面是数据和所需结果的示例

到目前为止，我已经能够生成新工作表并生成 ight 列，我缺少的是每个唯一用户 ID 的数据循环：

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

    ' Define the current Excel worksheet (where the data is stored)
    Set ws = ThisWorkbook.Sheets("Data") ' Replace "Data" with the name of your sheet

    ' Create a dictionary to store unique values
    Set uniqueValues = CreateObject("Scripting.Dictionary")

    ' Find the last row of data in the "Data" sheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Collect unique values from the "Question" column
    For i = 2 To lastRow ' Assuming data starts from row 2
        uniqueValues(ws.Cells(i, 7).value) = 1 ' Assuming "Question" column is column 7, modify accordingly
    Next i

    ' Create a new sheet for the unique values
    Set newWs = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    newWs.Name = "FinalReport" ' Replace with the desired sheet name

    ' Write the unique values in adjacent columns in the new sheet
    
    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
    
    ' Loop through the "Answers" column in the newly created sheet
  
End Sub

非常感谢任何帮助！

SQL Excel VBA

Sub CreateNewSheetWithUniqueValues()
    
    Const FIXED_COLS As Long = 6
    Dim ws As Worksheet, wb As Workbook
    Dim newWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim RowMap As Object, ColMap As Object, q As String, ans As String
    Dim value As Variant, k As String, rw As Long, col As Long

    Set RowMap = CreateObject("Scripting.Dictionary")
    Set ColMap = CreateObject("Scripting.Dictionary")
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Data") 'sheet with data
    Set newWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)) 'new sheet
    newWs.Range("A1").Resize(1, FIXED_COLS).value = _
           ws.Range("A1").Resize(1, FIXED_COLS).value  'copy headers for fixed columns
    
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    rw = 2               'first row position on output sheet
    col = FIXED_COLS + 1 'first question header column on output sheet
    For i = 2 To lastRow ' Assuming data starts from row 2
        'generate key by combining all values from A-F with "|"
        k = Join(Application.Transpose( _
              Application.Transpose(ws.Cells(i, 1).Resize(1, FIXED_COLS).value)), "|")
        If Not RowMap.Exists(k) Then 'new row values combination?
            RowMap.Add k, rw         'map key to output row number
            newWs.Cells(rw, 1).Resize(1, FIXED_COLS).value = Split(k, "|")
            rw = rw + 1
        End If
        
        q = ws.Cells(i, 7).value 'question
        If Len(q) > 0 And Not ColMap.Exists(q) Then 'new question?
            ColMap.Add q, col             'map question to output column position
            newWs.Cells(1, col).value = q 'populate column header
            col = col + 1
        End If
        
        ans = ws.Cells(i, 8).value 'answer on this row
        If Len(ans) > 0 Then
            'put the answer in the appropriate cell
            newWs.Cells(RowMap(k), ColMap(q)).value = ans
        End If
        
    Next i  'next data row

End Sub

Excel 宏中的动态透视数据

Dynamic Pivot Data inside Excel Macro

评论

评论