How can I use Excel VBA to copy cells from one sheet to another and transposing data to a list

I'm tryin to figure out how to copy selected cells from one sheet to another and at the sametime transposing the data structure.

I would like to transpose from this:
to this:
Sofar I'm working on a makro e.g this:
Sub copy()
    Dim strSeek As String
    Dim strSeekWeek As String
    Const strSourceSheet As String = "RawData"
    Const strDestSheet As String = "Data"
    Dim r As Integer
    Dim found As Integer
    Dim rng As Range
    Dim c As Object
    Dim lrow As Integer
    Dim SletData As Range
    Dim i As Integer

    'select data
    Range("A1", Range("A" & Rows.Count).End(xlUp)).Select
    Set rng = Selection
    'copy    For Each c In rng

        Sheets(strDestSheet).Range("A1").Offset(r, 0).Value = c.Offset(0, 0).Value
        Sheets(strDestSheet).Range("A1").Offset(r, 1).Value = c.Offset(0, 1).Value
        Sheets(strDestSheet).Range("A1").Offset(r, 2).Value = c.Offset(0, 2).Value
        Sheets(strDestSheet).Range("A1").Offset(r, 3).Value = c.Offset(0, 3).Value
        Sheets(strDestSheet).Range("A1").Offset(r, 4).Value = c.Offset(0, 4).Value
        Sheets(strDestSheet).Range("A1").Offset(r, 5).Value = c.Offset(0, 5).Value
        Sheets(strDestSheet).Range("A1").Offset(r, 6).Value = c.Offset(0, 6).Value
       'missing out here
        r = r + 1
    Next c
    MsgBox "Data copy", vbOKOnly
End Sub

Open in new window

but i'm having troble to handle the loops around each dataset in the "rawdata" section (every 15 rows are related to each other) and missing the code to built the new structure

Sincerely :-)
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Do you need the days of the week names translated?
I added the following routine in a module.  For testing purposes, I moved the data into a new worksheet (Sheet1).  I think it is a simpler implementation of what you want to do.
Sub Q_28499549()
    Dim rngTgt As Range
    Dim rngSrc As Range
    Dim rngDays As Range
    Dim rng As Range
    Dim wksSrc As Worksheet
    Dim wksTgt As Worksheet
    Set wksSrc = Worksheets("RawData")
    Set wksTgt = Worksheets("Sheet1")
    Set rngSrc = wksSrc.Range("A1")
    Set rngTgt = wksTgt.Range("A2")
    Application.ScreenUpdating = False
        For Each rng In wksSrc.Range(rngSrc.Offset(1, 1), rngSrc.Offset(1, 1).End(xlToRight))
            wksTgt.Range(rngTgt, rngTgt.Offset(11)).Value = rngSrc.Value
            wksTgt.Range(rngTgt, rngTgt.Offset(11)).Offset(, 1).Value = rng.Value
            wksTgt.Range(rngTgt, rngTgt.Offset(11)).Offset(, 2).Value = wksSrc.Range(rngSrc.Offset(2), rngSrc.Offset(2).End(xlDown)).Value
            wksTgt.Range(rngTgt, rngTgt.Offset(11)).Offset(, 3).Value = wksSrc.Range(rng.Offset(1), rng.Offset(1).End(xlDown)).Value
            Set rngTgt = rngTgt.End(xlDown).Offset(1)
        Set rngSrc = rngSrc.End(xlDown).End(xlDown).End(xlDown)
    Loop Until (rngSrc.Row = wksSrc.Rows.Count) _
                Or (Len(rngSrc.Offset(1, 1).Value) = 0)
    Application.ScreenUpdating = True
End Sub

Open in new window

I've also attached the updated workbook with the new code and worksheet.

This does not clear the target worksheet, so you would need to retain that part of your code when you integrate this code into your project, or just clear manually.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
LDiersAuthor Commented:
Great solution, much more simple! Thank you so much
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.