Como combinar dados de linha em colunas com base no ID exclusivo

Question

Resultado desejado:

TKID    Question        LEVEL
18176    PowerPoint         3
         Excel              3
         Access             3

Tabela inicial

TKID    Powerpoint  Excel      Access
18176      3          3          3

Essencialmente, eu quero colocar a questão (powerpoint, excel, Access) em uma coluna e a habilidade correspondente em uma coluna, todas ainda ligadas ao número TKID.

Eu consegui fazer isso manualmente através da função offset mas estou querendo saber se existe um método vba já que eu tenho centenas de linhas / colunas de dados. Cada TKID tem 278 perguntas que precisam ser colocadas na coluna da questão. Então cada TKID repetido.

    

Answer 1

Como isso funciona para o que você está tentando?

   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

Note, suponho que seus dados estejam dispostos assim, em "Folha1" (altere esse nome conforme necessário):

eficaráassimquandoterminar:

Por favor, note que eu suponho que sua Sheet2 terá uma linha de cabeçalho antes de você iniciar a macro.