有没有办法根据行的相邻值从行中创建列？

Question

最初，我从清理/过滤掉的 CSV 数据开始。这是一个非常大的数据集。以下是我希望实现的目标：

我尝试过的：

我的方法是首先将带有名称的列复制到新工作表中，然后删除所有重复项，然后使用匹配和索引来创建新列。不幸的是，由于数据量大，excel 崩溃了。

有没有我可以使用的 excel 命令？或者也许是VBA？感谢您的帮助。

Answer 1

假设源数据在A:C 列中，输出在E:H 列中：

Sub TransposeTable()
    Dim lastRow&, r&, x&, j&
    x = 1: r = 2
    While Len(Cells(r, "A")) > 0
        x = x + 1
        lastRow = Columns("A:A").Find(Cells(r, "A"), LookAt:=xlWhole, SearchDirection:=xlPrevious).Row
        Cells(x, "E") = Cells(r, "A")
        For j = r To lastRow
            Cells(x, GetColumn(Cells(j, "C"))) = Cells(j, "B")
        Next
        r = lastRow + 1
    Wend
End Sub

Private Function GetColumn&(strAttribute)
    Select Case strAttribute
        Case "Weight": GetColumn = 6
        Case "Age":    GetColumn = 7
        Case "Height": GetColumn = 8
    End Select
End Function

Answer 2

在单元格D2中添加如下图所示的辅助列...

...然后你可以在右侧看到，我有转换后的表格。

在单元格G2中，这是公式...

=IFERROR(INDEX($B:$B,MATCH($F2 & "_" & G$1,$D:$D,0)),"")

...现在将其填充到网格的其余部分。

如果这对您不起作用，那么您可以随时使用宏。取决于数据的大小以及手动维护该矩阵的痛苦程度。

Answer 3

此代码将从名为“Sheet1”的源工作表中获取数据。自动检测到最后一行。它假定数据从第 2 行开始（第 1 行保留给未使用的标题）。该宏在名为“Sheet2”的工作表中创建输出。

首先，为唯一名称和类型创建了 2 个集合。多亏了这一点，我们知道输出表有多大，并且有所有可能的值，我们可以在第二次迭代中找到匹配的值。

Option Explicit
Option Base 1

Sub ProcessData()

    Dim vSource As Variant, vOut() As Variant
    Dim lastRow As Long, nCounter As Long, outNameCounter As Long, outTypeCounter As Long
    Dim colNames As New Collection, colTypes As New Collection
    Dim itm

    Const nameCol As Long = 1
    Const valueCol As Long = 2
    Const typeCol As Long = 3

    With ThisWorkbook.Worksheets("Sheet1") 'source worksheet named "Sheet1"
        lastRow = .Cells.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        vSource = .Range(.Cells(1, 1), .Cells(lastRow, 3))
    End With

    For nCounter = LBound(vSource) + 1 To UBound(vSource) 'skip header
        On Error Resume Next
        colNames.Add vSource(nCounter, nameCol), CStr(vSource(nCounter, nameCol))
        colTypes.Add vSource(nCounter, typeCol), CStr(vSource(nCounter, typeCol))
        On Error GoTo 0
    Next nCounter

    ReDim vOut(1 + colNames.Count, 1 + colTypes.Count) 'create output table based on unique names and types count

    vOut(1, 1) = "Name"

    For nCounter = 1 To colNames.Count 'fill output table names
        vOut(nCounter + 1, 1) = colNames(nCounter)
    Next nCounter

    For nCounter = 1 To colTypes.Count 'fill output table types
        vOut(1, nCounter + 1) = colTypes(nCounter)
    Next nCounter

    For nCounter = LBound(vSource) + 1 To UBound(vSource) 'match source table data with output table names and types
        For outNameCounter = LBound(vOut) + 1 To UBound(vOut)
            If vSource(nCounter, nameCol) = vOut(outNameCounter, nameCol) Then
                For outTypeCounter = LBound(vOut, 2) + 1 To UBound(vOut, 2)
                    If vSource(nCounter, typeCol) = vOut(1, outTypeCounter) Then
                        vOut(outNameCounter, outTypeCounter) = vSource(nCounter, valueCol)
                        Exit For
                    End If
                Next outTypeCounter
                Exit For
            End If
        Next outNameCounter
    Next nCounter

    With ThisWorkbook.Worksheets("Sheet2") 'output worksheet named "Sheet2"
        Application.ScreenUpdating = False
        .Cells.ClearContents 'clear contents of whole worksheet
        .Range(.Cells(1, 1), .Cells(UBound(vOut), UBound(vOut, 2))) = vOut 'paste output table
        Application.ScreenUpdating = True
    End With

End Sub

Answer 4

我喜欢使用删除重复项的想法，但您应该使用数组进行一对一传输。

Option Explicit

Sub TransposeValues()

    Dim i As Long, j As Long
    Dim arr1 As Variant, arr2 As Variant, types As Variant, names As Variant
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Worksheets("sheet5")
    Set ws2 = Worksheets.Add(after:=ws1)

    'set up types
    With ws1.Range(ws1.Cells(1, "C"), ws1.Cells(ws1.Rows.Count, "C").End(xlUp))
        ws2.Cells(1, "A").Resize(.Rows.Count, .Columns.Count) = .Value
    End With
    With ws2.Range(ws2.Cells(1, "A"), ws2.Cells(ws2.Rows.Count, "A").End(xlUp))
        .RemoveDuplicates Columns:=1, Header:=xlYes
    End With
    With ws2.Range(ws2.Cells(1, "A"), ws2.Cells(ws2.Rows.Count, "A").End(xlUp))
        .Cells(1, "A").Resize(.Columns.Count, .Rows.Count) = _
          Application.Transpose(.Value)
        .Clear
    End With

    'set up names
    With ws1.Range(ws1.Cells(1, "A"), ws1.Cells(ws1.Rows.Count, "A").End(xlUp))
        ws2.Cells(1, "A").Resize(.Rows.Count, .Columns.Count) = .Value
    End With
    With ws2.Range(ws2.Cells(1, "A"), ws2.Cells(ws2.Rows.Count, "A").End(xlUp))
        .RemoveDuplicates Columns:=1, Header:=xlYes
    End With

    'collect source array
    arr1 = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Offset(0, 2)).Value

    'create target array and matrix header arrays
    With ws2
        arr2 = .Cells(1, "A").CurrentRegion.Cells.Value
        types = .Range(.Cells(1, "A"), .Cells(1, .Columns.Count).End(xlToLeft)).Value
        names = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value
    End With

    'move source to target
    For i = 2 To UBound(arr1, 1)
        arr2(Application.Match(arr1(i, 1), names, 0), _
             Application.Match(arr1(i, 3), types, 0)) = arr1(i, 2)
    Next i

    'transfer target array to worksheet
    ws2.Cells(1, "A").Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2

    'name new target worksheet
    ws2.Name = "Target"

End Sub