How would I automate the transposing of the data in the attached xlsx file?

Posted on 2012-08-27
Last Modified: 2012-08-27
I would like to automate the transposing of the data in the attached file so that for example,
the data on sheet "d" is transformed into the "resultsSHEET d" format. Each sheet in the file would be transformed in the same manner -  much more user friendly -

Question by:PDSWSS
    LVL 17

    Accepted Solution

    Try this - I have assumed there are always exactly 14 questions - this would need a rework if it could vary.
    Option Explicit
    Public Sub Test()
        Call TransposeIt(ActiveWorkbook.Worksheets("d"))
    End Sub
    Public Sub TransposeIt(ByVal wks As Excel.Worksheet)
        Dim strSheet As String
        Dim results As Excel.Worksheet
        Dim rngIn As Excel.Range
        Dim rngWork As Excel.Range
        Dim rngOut As Excel.Range
        Const lngNUMQs As Long = 14         ' number of questions
        strSheet = "ResultsSHEET " & wks.Name
        On Error Resume Next
        Set results = ActiveWorkbook.Worksheets(strSheet)
        On Error GoTo 0
        ' create the output sheet, or delete the contents of the original sheet
        If results Is Nothing Then
            Set results = ActiveWorkbook.Worksheets.Add
            results.Name = strSheet
        End If
        results.Cells(1).Value = "Subject id"
        ' get the question numbers
        Set rngWork = wks.Cells(2, 3).Resize(lngNUMQs, 1)
        results.Cells(1, 2).Resize(1, lngNUMQs).Value = Application.WorksheetFunction.Transpose(rngWork)
        ' now put in the subject id
        Set rngOut = results.Cells(2, 1)
        Set rngIn = wks.UsedRange.Cells(2, 1)
        ' loop while still data
        Do While Len(Trim$(rngIn.Value)) > 0
            rngOut.Value = rngIn.Value          ' the subject id
            Set rngWork = rngIn.Offset(0, 1).Resize(lngNUMQs, 1)
            rngOut.Offset(0, 1).Resize(1, lngNUMQs).Value = Application.WorksheetFunction.Transpose(rngWork)
            Set rngOut = rngOut.Offset(1, 0)            ' skip to next output row
            Set rngIn = rngIn.Offset(lngNUMQs, 0)       ' skip to next block
    End Sub

    Open in new window


    Author Comment

    Excellent answer. Worked as requested.
    Question - if  >  or  <  14

    Would  changing the "14" in this line "Const lngNUMQs As Long = 14"
    to the correct number of questions suffice?


    Author Comment

    Just tested and see that changing that number works.
    Will give you the points now. Thanks again.

    Author Closing Comment

    Great job!

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    IT, Stop Being Called Into Every Meeting

    Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

    A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
    This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
    The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
    This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

    760 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    8 Experts available now in Live!

    Get 1:1 Help Now