☰

如何预处理 MS Excel 中的行以根据公共列值创建系列数据

tag-icon • tag-icon microsoft-excel vba macros
如何预处理 MS Excel 中的行以根据公共列值创建系列数据

我有几百行数据，其中一列包含学生姓名，一列包含作业 ID，一列包含分数。我正在寻找 MS Excel 中预处理数据集的方法，可以使用内置函数或 VB 宏，以便将分数组织成一系列以学生姓名为标签的分数。如果可能的话，我想在绘制图表时使用作业 ID 作为 y 轴标签。MS Excel 中是否有用于预处理此类数据的宏或函数？

     A.        B.         C. 
1   Name      ID         Score
2   Al        1000       97%
3   Rob       1000       93%
4   Jack      1000       95% 
5   Al        1001       92%
6   Rob       1001       97%
7   Tim       1001       98%
8   Jack      1001       93%

转换为

 A.         B.         C. 
1 Name       1000      1001
2 Al         97%       92%
3 Rob        93%       97%
4 Jack       95%       93%
5 Tim                  98%

答案1

更新：
尝试插入一个数据透视表。 在此处输入图片描述

答案2

数据透视表列 (VBA 解决方案)

  • 第一列包含行标签 (R)。您想要旋转第二列，其中包含列标签 (C)。第三列包含值 (V)。
  • 该解决方案将涵盖前一种解决方案，它通常可能以不同的形式出现，例如，您可能想要旋转第一列，有多个行标签或列标签，值在另一列中，如果有重复项，您可能想要求和，等等。因此，我建议您研究另一种简单的方法（除了PivotTable）使用PowerQuery（以前Get & Transform）和大量选项来做到这一点。
  • 调整（使用）常量部分中的值。
Option Explicit

Sub PivotRCV()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "E1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Create a reference to the Source Range ('srg').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = RefColumns(sws.Range(sFirst).Resize(, 3))
    If srg Is Nothing Then Exit Sub ' empty columns, not even headers
    
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount = 1 Then Exit Sub ' only headers, no data
    
    ' Write the unique row labels to the Row Labels Array ('rLabels').
    Dim srrg As Range
    Set srrg = srg.Columns(1).Resize(srCount - 1).Offset(1)
    Dim rLabels As Variant: rLabels = ArrUniqueColumnRange(srrg)
    If IsEmpty(rLabels) Then Exit Sub ' only error values and/or blanks
    
    ' Write the unique column labels to the Column Labels Array ('cLabels').
    Dim scrg As Range
    Set scrg = srg.Columns(2).Resize(srCount - 1).Offset(1)
    Dim cLabels As Variant: cLabels = ArrUniqueColumnRange(scrg)
    If IsEmpty(cLabels) Then Exit Sub ' only error values and/or blanks
 
    ' Write values from the Source Range to the Source Array ('sData').
    Dim sData As Variant: sData = srg.Value
    
    ' Define the Destination Array ('dData').
    Dim drCount As Long: drCount = UBound(rLabels) + 2 ' both +1 - zero-based...
    Dim dcCount As Long: dcCount = UBound(cLabels) + 2 ' ... +1 - headers
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)

    ' Write to Destination Array.
    dData(1, 1) = sData(1, 1) ' First (Row Label) Header
    Dim n As Long
    For n = 0 To drCount - 2 ' Row Labels
        dData(n + 2, 1) = rLabels(n)
    Next n
    For n = 0 To dcCount - 2 ' Column Labels
        dData(1, n + 2) = cLabels(n)
    Next n
    Dim r As Long
    Dim c As Long
    For n = 2 To srCount ' Values
        r = Application.Match(sData(n, 1), rLabels, 0) + 1
        c = Application.Match(sData(n, 2), cLabels, 0) + 1
        dData(r, c) = sData(n, 3)
    Next n

    ' Create a reference to the Destination Range ('drg').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drg As Range: Set drg = dws.Range(dFirst).Resize(drCount, dcCount)
    
    ' Write to the Destination Range.
    'drg.Clear
    drg.Value = dData
    
    ' Format the Destination Range.
    With drg.Rows(1) ' Headers
        .Font.Bold = True
    End With
    With drg.Resize(drCount - 1, dcCount - 1).Offset(1, 1) ' Values
        .NumberFormat = "0%"
    End With
    
    ' Inform user.
    MsgBox sData(1, 2) & " column pivoted successfully.", _
        vbInformation, "Pivot RCV"

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range from a row range
'               ('FirstRowRange') to the row range containing
'               the bottom-most non-empty cell in the given row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
    ByVal FirstRowRange As Range) _
As Range
    If FirstRowRange Is Nothing Then Exit Function
    
    With FirstRowRange.Rows(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function ' empty range
        Set RefColumns = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values of a one-column range in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueColumnRange( _
    ColumnRange As Range) _
As Variant
    If ColumnRange Is Nothing Then Exit Function
    
    Dim Data As Variant
    Dim rCount As Long
    
    With ColumnRange.Columns(1)
        rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim r As Long
        For r = 1 To rCount
            Key = Data(r, 1)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    .Item(Key) = Empty
                End If
            End If
        Next r
        If .Count = 0 Then Exit Function ' only error values and/or blanks
        ArrUniqueColumnRange = .Keys
    End With

End Function

相关内容