使用Excel / VBA，如何将列组转置为多行，但仍将组元素保留在同一行中？

Question

我刚刚开始学习VBA，因此感谢任何帮助我解决问题的人。 我可能使用错误的术语来描述问题，但是基本上我正在尝试编写一个VBA宏以将数据从图片1转换为图片2的布局。

由于我只能附加屏幕快照，因此删除了项目标题和图片1中项目1之间的其他项目属性列，以及任务4至任务8的列组。但是，项目标题标题始终位于E6，项目位于AA6的1个标题和位于AX6的8号完成日期标题。

在图2中，标头项目标题将位于单元格B4中。 工作表1中的数据库将获得更多或更少的行，因此我希望能够在单击按钮时更新Sheet2。 如果可能，也让宏跳过空白项目单元格。 最终目标是绘制带有数据布局的甘特图。 我可以使用单元格形式和条件格式来制作甘特图，但我始终无法获得所需的数据布局。

我发现了一个与我的情况类似的问题，但不知道如何对其进行修改以适用于团体。 excel宏（VBA）将多列转置为多行

在这种情况下，“ Apple”或多或少地等同于我的项目1。“红色”等于（项目1，开始1，完成1）。 “绿色”类似于（项目2，开始2，完成2），依此类推。

让我知道是否需要进一步澄清。 非常感谢！

Answer 1

尝试此操作，即使可能有点混乱，它也应该可以完成工作。

Option Explicit

Sub Macro1()
Dim lRow As Long, lastColumn As Long, lngcol As Long
Dim lCol As String, colChar As String, strSearch As String
Dim i As Integer
Dim targetValue As Range, copyValue As Range
Dim wks As Worksheet, targetWks As Worksheet
Dim targetLastRowA As Long, targetLastRowB As Long, targetLastCol As Long

Application.ScreenUpdating = False

Set wks = ThisWorkbook.Sheets("Sheet1")
Set targetWks = ThisWorkbook.Sheets("Sheet2")

lRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
lastColumn = wks.Columns.SpecialCells(xlLastCell).Column

lCol = Col_Letter(lastColumn)

' Loop through rows
For i = 2 To lRow
    lngcol = 2

    targetLastCol = targetWks.Columns.SpecialCells(xlLastCell).Column

    With targetWks
    Set targetValue = targetWks.Columns("A:A").Find(What:=wks.Range("A" & i).Value, After:=.Cells(1, 1), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    End With

    If targetValue Is Nothing Then
        targetLastRowB = targetWks.Cells(targetWks.Rows.Count, "B").End(xlUp).Row
        wks.Cells(i, 1).Copy
        targetWks.Cells(targetLastRowB + 1, 1).PasteSpecial
        Application.CutCopyMode = False
    End If

    ' Loop through columns
    For lngcol = 2 To lastColumn Step 3

        colChar = Col_Letter(lngcol)
        strSearch = wks.Range(colChar & i)

        With targetWks
        Set copyValue = targetWks.Columns("B:B").Find(What:=strSearch, After:=.Cells(1, 2), LookIn:=xlFormulas, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
        End With

        targetLastRowB = targetWks.Cells(targetWks.Rows.Count, "B").End(xlUp).Row
        targetLastRowA = targetWks.Cells(targetWks.Rows.Count, "A").End(xlUp).Row

        If copyValue Is Nothing And targetWks.Range("A" & targetLastRowA).Offset(1, 1) = "" Then
            wks.Range(wks.Range(colChar & i), wks.Range(colChar & i).Offset(0, 2)).Copy
            targetWks.Cells(targetLastRowB, 1).Offset(2, 1).PasteSpecial xlPasteValues
        ElseIf copyValue Is Nothing Then
            wks.Range(wks.Range(colChar & i), wks.Range(colChar & i).Offset(0, 2)).Copy
            targetWks.Cells(targetLastRowB + 1, 2).PasteSpecial xlPasteValues
        End If
        Application.CutCopyMode = False

        Next
Next i
Application.ScreenUpdating = True
End Sub

Function Col_Letter(lngcol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngcol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function