Vba 使用新类别将列中的类别提取到重复的行中

我有一张这样的桌子：

Group   | Name     | Comment   | Tag 1       | Tag 2       | Tag 3
-------------------------------------------------------------------
gr1       Joe        We are...   SYSTEM        SUGGESTION    PAINPOINT
gr1       Joe        I want...   PROCESS       ATTITUDE

我需要运行一个宏来生成它（我使用的是Excel2007）

因此，所有标记都会获得重复的数据，但它们自己的行除外。这使我现在可以在一列中对信息进行排序和透视。我目前不太擅长VBA，希望能在这个问题上得到一些帮助

---

我希望这已经足够清楚了。

如果您真的需要将其作为vba代码，这里有一个可能的解决方案： （子程序中的一些附加注释） 经过尝试和测试

Sub Solution()

    'Select cell with 'Group' title
    'Result passed to 10th column to the right
    'Macro doesn't care of headers of result table

    Dim KOM As Range
    Dim partGNC As Variant
    Dim partTAG As Variant
    Dim resRow As Long
        resRow = ActiveCell.Row + 1
    For Each KOM In Range(ActiveCell.Offset(1, 0), ActiveCell.End(xlDown))

        partGNC = KOM.Resize(1, 3)
        partTAG = Range(KOM.Offset(0, 3), KOM.End(xlToRight))

        If KOM.Offset(0, 3).Address = KOM.End(xlToRight).Address Then

            Cells(resRow, KOM.Column + 10).Resize(1, 3) = partGNC
            Cells(resRow, KOM.Column + 13) = partTAG
            resRow = resRow + 1

        Else
            Cells(resRow, KOM.Column + 10).Resize(UBound(partTAG, 2), 3) = partGNC
            Cells(resRow, KOM.Column + 13).Resize(UBound(partTAG, 2), 1) = Application.Transpose(partTAG)
            resRow = resRow + UBound(partTAG, 2)
        End If


    Next

End Sub

---

一个不涉及使用VBA的想法-您可以只复制整个组、名称和注释列，然后将这三个列粘贴到标记1和标记2之间，并将它们粘贴到标记2和标记3之间吗？所以它是组|名称|注释| tag1 |组|名称|注释| tag2 |组|名称|注释| tag3？然后，您可以将相关的tag2块向下移动到所有tag1数据下面，依此类推。如果需要重复使用，可以录制为宏。（像这样：）是的，Reband先生的想法应该行得通。好吧，我有890行要做这一行，我想做很多空插槽，因为它转到“Tag 10”，大多数只使用2-3个标记。所以这可能是低效的。我还需要一些我以后可以重复使用的东西，而不需要对宏进行太多的调整。

Sub Solution()

    'Select cell with 'Group' title
    'Result passed to 10th column to the right
    'Macro doesn't care of headers of result table

    Dim KOM As Range
    Dim partGNC As Variant
    Dim partTAG As Variant
    Dim resRow As Long
        resRow = ActiveCell.Row + 1
    For Each KOM In Range(ActiveCell.Offset(1, 0), ActiveCell.End(xlDown))

        partGNC = KOM.Resize(1, 3)
        partTAG = Range(KOM.Offset(0, 3), KOM.End(xlToRight))

        If KOM.Offset(0, 3).Address = KOM.End(xlToRight).Address Then

            Cells(resRow, KOM.Column + 10).Resize(1, 3) = partGNC
            Cells(resRow, KOM.Column + 13) = partTAG
            resRow = resRow + 1

        Else
            Cells(resRow, KOM.Column + 10).Resize(UBound(partTAG, 2), 3) = partGNC
            Cells(resRow, KOM.Column + 13).Resize(UBound(partTAG, 2), 1) = Application.Transpose(partTAG)
            resRow = resRow + UBound(partTAG, 2)
        End If


    Next

End Sub