CODEWITHSUNDEEP
vbaexceltranspose
Todd Choi
Todd Choi

Reputation: 37

Excel VBA Transpose Variable Column Range to Variable Rows

Hello StackOverFlow Community,

I started working with excel vba not too long ago and could really use some help with a somewhat complex problem.

I have a spreadsheet with a column of "Prime" parts and its "Alternative" Parts below it. I need to create a macro that will transpose the Variable Alternative parts to the right of its associated Prime part. So for the Example below, in Column A "P" are Prime Parts and "A" are Altenates :

A |

1P |

1A |

1A |

1A |

2P |

2A |

2A |

3P |

3A |

I trying to create a macro that will give me the following results:

A || B || C || D |

1P | 1A | 1A | 1A

1A |

1A |

1A |

2P | 2A | 2A

2A |

2A |

3P | 3A

3A |

Below is the Code that I was able to come up with, but all of the Alternate parts consolidate into one range and transpose to the first Prime part of the list. I understand that this may not be the best method for what I am trying to accomplish. I am open to all suggestion and looking forward to hearing some awesome solutions.

Please note that the Bolded Prime parts in the above example are actually highlighted on my spreadsheet which would explain the "colorindex = 6" in the code

Sub NewHope()

Dim cell As Range
Dim LastRow As Long
Dim Prime As Range
Dim alt As Range


LastRow = Range("A" & Rows.Count).End(xlUp).Row

For Each cell In Range("A2:A" & LastRow)
    If cell.Interior.ColorIndex = 6 Then
        If Prime Is Nothing Then
            Set Prime = cell
        End If
    Else
        If alt Is Nothing Then
            Set alt = cell
        Else
            Set alt = Union(alt, cell)
        End If

    End If
Next

alt.Copy
Prime.Offset(0, 4).PasteSpecial Transpose:=True

End sub

Upvotes: 2

Views: 735

Answers (3)

EEM
EEM

Reputation: 6659

This solution uses AutoFilter, Range.Areas and Arrays in order to avoid looping through each of the cells, improving the processing speed...

    Sub TEST_Transpose_Alternates_To_Prime()
    Dim wsTrg As Worksheet, rgTrg As Range
    Dim rgPrime As Range, rgAlter As Range
    Dim rgArea As Range, aAlternates As Variant
    Dim L As Long

        Set wsTrg = ThisWorkbook.Worksheets("DATA")    'Change as required
        With wsTrg
            Application.Goto .Cells(1), 1
            If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
            Set rgTrg = .Cells(6, 2).CurrentRegion.Columns(1)  'Change as required
        End With

        Rem Set Off Application Properties to improve speed
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

        With rgTrg
            Rem Set Primes Range
            .AutoFilter Field:=1, Criteria1:="=*P"
            Set rgPrime = .Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible)

            Rem Set Alternates Range
            .AutoFilter Field:=1, Criteria1:="=*A"
            Set rgAlter = .Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible)

            Rem Clear Filters
            .AutoFilter
        End With

        Rem Validate Prime & Alternate Ranges
        If rgPrime.Areas.Count <> rgAlter.Areas.Count Then Exit Sub

        Rem Post Alternates besides each Prime
        rgTrg.Cells(1).Offset(0, 1).Value = "Alternates..."

        For Each rgArea In rgAlter.Areas

            With rgPrime

                L = 1 + L
                aAlternates = rgArea.Value2

                If rgArea.Cells.Count > 1 Then
                    aAlternates = WorksheetFunction.Transpose(aAlternates)
                    .Areas(L).Cells(1).Offset(0, 1).Resize(1, UBound(aAlternates)).Value = aAlternates

                Else
                    .Areas(L).Cells(1).Offset(0, 1).Value = aAlternates

        End If: End With: Next

        Rem Refresh Application Properties
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.EnableEvents = True

        End Sub

Upvotes: 0

user4039065
user4039065

Reputation: 

If Prime Is Nothing Then

The above code does not seem to do what you require; it does not reset the 'prime' cell since after the first location of a 'prime' cell, Prime will never be nothing again.

dim r as long, pr as long

For r=2 to Range("A" & Rows.Count).End(xlUp).Row
    If cells(r, "A").Interior.ColorIndex = 6 Then
        pr = r
    Else
        cells(pr, columns.count).end(xltoleft).offset(0,1) = cells(r, "A").value
    End If
Next

This code would be better with a properly referenced parent worksheet reference.

Upvotes: 0

user8753746
user8753746

Reputation:

Try this code:

Sub test()
Dim cell As Range
Dim LastRow As Long
Dim PrimeRow As Long
Dim PrimeColumn As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row

For Each cell In Range("A2:A" & LastRow)
    If cell.Interior.ColorIndex = 6 Then
        PrimeRow = cell.Row
        PrimeColumn = cell.Column + 1
    Else
        Cells(PrimeRow, PrimeColumn).Value = cell.Value
        PrimeColumn = PrimeColumn + 1
    End If
Next

End Sub

Upvotes: 2

Related Questions