Advanced transpose macro

Hi,

I am desperately seeking a better way of transposing a large amount of data. By the looks of other posts, my objective is possible with a bit of VBA. Sadly, I am VBA illiterate. I sincerely appreciate your help.

My data looks like this (simplified) [ data is separated by columns "|".

A | May 1 | Jun 25 | Aug 9 | Dec 12
B | Apr 1 | Oct 25
C | Jan 6 | July 7 | Nov 11

I want to make it look like this:
A | May 1
A | June 25
A | Aug 9
A | Dec 12
B | Apr 1
B | Oct 25
C | Jan 6
C | Jul 7
C | Nov 11

I have accomplished this in the past, but it involved importing the table into access, then creating a query for each of the "date" columns, then copying and pasting the results into one table. It was a painful experience considering there are over 2,000 lines on the original table (resulting in 25,00 lines in the combined query).

Any insight you have would be very very greatly appreciated.

-J

I saw this on another post, but it needs some mod to work in my situation. Thanks for your help!

Sub test()
     Dim ResultArray, _
     SingleName                    As String, _
     ColorVal                 As String, _
     NamesToGet               As String, _
     ReadInString             As String, _
     RowCount                 As Long, _
     TestRow                  As Long, _
     NameCount                As Long, _
     Ctrl                     As Long, _
     BarPos                   As Integer, _
     LISTSHT                  As Worksheet, _
     PARSED                   As Worksheet

     
     
     Set LISTSHT = Sheets("Sheet1")          'original unprocessed sheet
     Set PARSED = Sheets("parsed")           ' sheet to hold code output
     
     RowCount = LISTSHT.Cells(Rows.Count, "A").End(xlUp).Row
     
     For TestRow = 1 To RowCount 'Step -1
          ReadInString = LISTSHT.Range("A" & TestRow)
          BarPos = InStr(1, ReadInString, "|")
          ColorVal = Trim(Left(ReadInString, BarPos - 1))
          NamesToGet = Mid(ReadInString, BarPos + 1)
          ResultArray = Split(NamesToGet, ",")
          
          If UBound(ResultArray) = -1 Then
               NameCount = NameCount + 1
               PARSED.Cells(NameCount, 1).Value = ColorVal
          Else
               For Ctrl = 0 To UBound(ResultArray)
                    NameCount = NameCount + 1
                    PARSED.Cells(NameCount, 1).Value = ColorVal
                    SingleName = Trim(ResultArray(Ctrl))
                    PARSED.Cells(NameCount, 2).Value = SingleName
               Next Ctrl
          End If
     Next TestRow
End Sub

Here is an excerpt of the data I am trying to transpose.

Thank you again for your help.

J

Does this do what you want? It puts the results on sheet2.

Sub x()

Dim rng As Range

Application.ScreenUpdating = False

Sheet1.Activate
For Each rng In Range("A3", Range("A3").End(xlDown))
    Range(rng, rng.End(xlToRight)).Copy
    Sheet2.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Transpose:=True
Next rng

Application.ScreenUpdating = True

End Sub

This is pretty close, but I need to have the original data in column A repeated alongside the transposed dates (now in column B).

Like this:
PN | Date
A | Jun 1
A | July 1
A | Aug 4

Currently, its like this:
A
Jun 1
July 1
Aug 4

Thanks for your amazingly quick response.

J.

Try this:

Option Explicit

Sub x()

Dim rng As Range, rng2 As Range

Application.ScreenUpdating = False

Sheet1.Activate
For Each rng In Range("A3", Range("A3").End(xlDown))
    Set rng2 = Range(rng.Offset(, 1), rng.End(xlToRight))
    rng2.Copy
    With Sheet2.Cells(Rows.Count, 1).End(xlUp)(2)
        .Offset(, 1).PasteSpecial Transpose:=True
        .Resize(rng2.Columns.Count) = rng
    End With
Next rng

Application.ScreenUpdating = True

End Sub

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.