Question

最初，我从清理/过滤出的CSV数据开始。这是一个非常大的数据集。这是我希望完成的事情：

我尝试过的事情：

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

我可以使用任何Excel命令吗？也许是VBA？感谢您的帮助。

Answer 1

添加一个助手列，如下图所示，在单元格 D2 ...

中

...然后如您所见，在右侧，我有了转换后的表格。

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

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

...现在将其填充并覆盖网格的其余部分。

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

Answer 2

此代码将从名为“ 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 3

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

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

Answer 4

假设源数据在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

有没有一种方法可以根据行的相邻值在行外创建列？

4 个答案: