使用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