CODEWITHSUNDEEP
vbaexcelmacros
Brian B
Brian B

Reputation: 13

With Excel/VBA, how can I transpose groups of columns into multiple rows, but still keeping the group elements within the same row?

I just started learning VBA, so I would appreciate anyone helping me to solve the problem. I might use the wrong terminology to describe the question, but basically I am trying to write a VBA macro to transpose the data from picture 1 to the layout in picture 2.

Since I can only attach screen shots, I delete other project attribute columns between project title and Item 1 in picture 1, as well as column groups for task 4 to task 8. However, the project title header will always be located at E6, Item 1 header located at AA6 and Item 8 Finish Date header located at AX6.

In picture 2, the header project title will be located at cell B4. The database in sheet 1 will be getting more or less rows, so I want be able to update Sheet2 when I click a button. If possible, also have the macro skip the blank item cells. The ultimate goal is to plot a gantt chart with the data layout. I can do the gantt chart with cell formuala and conditional formating, but I am stuck in getting the desired data layout.

I found a problem similar to my situation but don't know how to modify it to work for groups. excel macro(VBA) to transpose multiple columns to multiple rows

In that case, "Apple" is more or less equivent to my project 1. "Red" is equivalent to (Item 1, Start 1, Finish 1). "Green" is similar to (Item 2, Start 2, Finish 2), so on and so forth.

Let me know if further clarification is needed. Thanks so much!

enter image description here

enter image description here

Upvotes: 1

Views: 1306

Answers (1)

Niclas
Niclas

Reputation: 1262

Try this, it should do the job even though it might be a bit messy.

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

Upvotes: 2

Related Questions