Есть ли способ создать столбцы из строк в зависимости от соседнего значения строки?

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

Этот код будет получать данные из исходного листа с именем «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

Добавьте вспомогательный столбец, как показано на рисунке ниже, в ячейку D2 ...

... thenкак вы видите справа, у меня есть преобразованная таблица.

В ячейке G2 , это формула ...

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

..Заполните это и в остальной части сетки.

Если это не сработает, то вы всегда можете использовать макрос.Зависит от размера ваших данных и от того, насколько сложно поддерживать эту матрицу вручную.