如何根据唯一 ID 将行数据合并到列中

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

请注意，我假设您的数据在“Sheet1”上布局如下（根据需要更改该名称）：

完成后看起来如下：

请注意，我假设您的 Sheet2 将有一个标题行前你启动宏。