Question

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

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

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

我发现了一个类似于我的情况的问题，但我不知道如何修改它以适用于群组。 excel macro(VBA) to transpose multiple columns to multiple rows

在这种情况下，＆＃34; Apple＆＃34;或多或少与我的项目1等同。＆＃34; Red＆＃34;相当于（第1项，第1项，第1项）。＆＃34;绿色＆＃34;类似于（第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

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

1 个答案: