使用Excel / VBA，如何将多组列转换为多行，但仍然将组元素保持在同一行内？

我刚开始学习VBA，所以我会很感激任何人帮助我解决问题。 我可能会用错误的术语来描述这个问题，但基本上我正在尝试编写一个VBAmacros来将图片1中的数据转换为图2中的布局。

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

在图2中，标题项目标题将位于单元格B4。 工作表1中的数据库将获得更多或更less的行，所以我希望能够在单击button时更新Sheet2。 如果可能的话，也有macros跳过空白项目单元格。 最终目标是用数据布局绘制一张甘特图。 我可以用单元格formuala和条件格式来做甘特图，但是我被困在获得所需的数据布局。

我发现一个类似于我的情况的问题，但不知道如何修改它为群组工作。 Excelmacros（VBA）将多列转置为多行

在这种情况下，“苹果”或多或less与我的项目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