Как объединить данные строки в столбцы на основе уникального идентификатора

Question

Желаемый результат:

TKID    Question        LEVEL
18176    PowerPoint         3
         Excel              3
         Access             3

Начальная таблица

TKID    Powerpoint  Excel      Access
18176      3          3          3

По сути, я хочу поместить вопрос (powerpoint, excel, Access) в столбец, а соответствующий навык в столбце все еще привязан к номеру TKID.

Я смог сделать это вручную с помощью функции смещения, но мне интересно, если есть метод VBA, поскольку у меня есть сотни строк / столбцов данных. Каждый TKID имеет 278 вопросов, которые необходимо вставить в столбец вопросов. Затем каждый TKID повторяется.

Answer 1

Как это работает для того, что вы пытаетесь?

   Sub transposeData()
Dim lastRow As Long, lastCol As Long, curLastCol As Long, nRow As Long
Dim groupHeaders() As Variant, levels() As Variant
Dim mainWS As Worksheet, newWS As Worksheet
Dim tkid    As String

Set mainWS = Worksheets("Sheet1")
Set newWS = Worksheets("Sheet2")
nRow = newWS.Cells(newWS.Rows.Count, 2).End(xlUp).Row

With mainWS
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Dim curGroup As Range
Dim i As Long, k As Long

For i = 2 To lastRow         ' using 2, since you have header row
    curLastCol = mainWS.Cells(i, 1).End(xlToRight).Column
    Set curGroup = mainWS.Range(mainWS.Cells(i, 1), mainWS.Cells(i, curLastCol))
    tkid = curGroup.Cells(1, 1).Value

    ReDim groupHeaders(1 To curGroup.Columns.Count - 1)
    ReDim levels(1 To curGroup.Columns.Count - 1)
    For k = 1 To curGroup.Columns.Count - 1
        groupHeaders(k) = mainWS.Cells(1, k + 1)
        levels(k) = mainWS.Cells(i, k + 1)
    Next k

    With newWS
        .Cells(nRow + 1, 1).Value = tkid
        For k = LBound(groupHeaders) To UBound(groupHeaders)
            .Cells(nRow + k, 2).Value = groupHeaders(k)
            .Cells(nRow + k, 3).Value = levels(k)
        Next k

    End With
    nRow = newWS.Cells(newWS.Rows.Count, 2).End(xlUp).Row
Next i

newWS.Activate
copyDownData ("A")

End Sub
Sub copyDownData(Optional ByVal iCol As String)
' This will allow us to quickly copy data down a column.
If IsMissing(iCol) Then
    iCol = InputBox("What column, USING THE LETTER REFERENCE, do you want to copy down?")
End If

Range(Cells(2, iCol), Cells(Rows.Count, iCol)).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Columns(iCol).EntireColumn.Value = Columns(iCol).EntireColumn.Value

End Sub

Обратите внимание, я предполагаю, что ваши данные размещены следующим образом:"Лист1" (при необходимости измените это имя):

и это будет выглядеть следующим образом:

Обратите внимание, что я предполагаю, что ваш Sheet2 будет иметь строку заголовка, прежде чем вы запустите макрос.