Jak połączyć dane wierszy w kolumny na podstawie unikalnego identyfikatora

Pożądany wynik:

TKID    Question        LEVEL
18176    PowerPoint         3
         Excel              3
         Access             3

Tabela początkowa

TKID    Powerpoint  Excel      Access
18176      3          3          3

Zasadniczo chcę umieścić pytanie (powerpoint, excel, dostęp) w kolumnie, a umiejętność dopasowania w kolumnie nadal powiązana z numerem TKID.

Mogłem to zrobić ręcznie za pomocą funkcji offset, ale zastanawiam się, czy istnieje metoda vba, ponieważ mam setki wierszy / kolumn danych. Każdy TKID ma 278 pytań, które należy przeciągnąć do kolumny pytań. Następnie każdy TKID powtarza się.

Jak to działa w przypadku tego, czego próbujesz?

   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

Uwaga: zakładam, że twoje dane są ułożone w ten sposób na „Arkuszu 1” (w razie potrzeby zmień tę nazwę):

i po zakończeniu będzie wyglądać następująco:

Pamiętaj, że zakładam, że Twój arkusz2 będzie miał wiersz nagłówka przed uruchomieniem makra.