Advanced transpose macro

**shg** · 12-19-2008, 08:31 PM

Maybe ...

Sub x()
    Dim rInp    As Range
    Dim rOut    As Range
    Dim cell    As Range

    Application.ScreenUpdating = False

    Sheet2.Cells.ClearContents
    Set rOut = Sheet2.Range("A1")
    Sheet1.Select
    
    For Each cell In Range("A3", Range("A3").End(xlDown))
        With cell
            Set rInp = Range(.Offset(, 1), .Offset(, 1).End(xlToRight))
            With rOut.Resize(rInp.Columns.Count)
                .Value = cell.Value
                .Offset(, 1).Value = WorksheetFunction.Transpose(rInp.Value)
            End With
            Set rOut = rOut.Offset(rInp.Columns.Count)
        End With
    Next cell

    Application.ScreenUpdating = True
End Sub

Edit: Stephen, I thought you were off drinking eggnog

**jlepard** · 12-19-2008, 10:58 PM

Thanks very much for the amazing insight on this. I didnt have a chance to check it before I left for the weekend. It will be the first thing I do on Monday.

Thanks again and have a great weekend.

**StephenR** · 12-20-2008, 09:37 AM

shg: taking it easy ... too much eggnog the day before.

**jlepard** · 01-05-2009, 07:36 PM

Hi again,

The macro you've provided works great. I wondered if I could ask your wisdom on how to modify it slightly. In some cases, I there are two (or more) columns of data between the Part Number and the series of Dates to transpose. What aspect of the code would I modify to expand the range?
I have attached an example for clarification.

I made several attempt to figure it out myself, but it didnt work out at all

Thank you again very kindly.

J.

**StephenR** · 01-06-2009, 07:55 AM

Have amended the code and added a few comments which I hope elucidate matters. Come back if not. If it's going to vary a lot, you could do something fancier, such as prompting the user to specify which columns to transpose etc.

Sub x()

Dim rng As Range, rng2 As Range

Application.ScreenUpdating = False

Sheet1.Activate
For Each rng In Range("A2", Range("A2").End(xlDown))
    ' the offset number below is the number of cols from PN to first date
    Set rng2 = Range(rng.Offset(, 3), rng.End(xlToRight))
    rng2.Copy
    With Sheet2.Cells(Rows.Count, 1).End(xlUp)(2)
        ' repeat offset below
        .Offset(, 3).PasteSpecial Transpose:=True
        ' second resize number below is no of cols before dates to be copied
        .Resize(rng2.Columns.Count, 3) = rng.Resize(, 3).Value
    End With
Next rng

Application.ScreenUpdating = True

End Sub

**jlepard** · 01-06-2009, 11:18 AM

Amazing - thank you so very much. I sincerely appreciate your help. If this parameters change, I think I can use your comments to modify the code. Thank you again.

-J.