Solved

How would I make the transformations described in this question using code?

Posted on 2011-10-21
191 Views
I have attached an excel 2007 spreadsheet (Sample) that contains a small sample of a larger output file.
Another sheet is included with the expected output.

These data represent 4 subjects (Column A) who answered 8 questions. Questions 1,2,3, 7, 8 have 5 possible answers numbered  0-4, represented in columns B:P ( Q 1-3) and Z:AI (Q 7,8) in Row 1. Questions 4,5,6 have 3 possible answers numbered 0-2 in columns R:Y in row 1. Each subject chose 1 of the 5 answers for Q 1-3, 7,8 and chose one of the 3 answers for Q 4-6. The answer they chose is marked in that subject's row under the appropriate column with a 1. I need code that would transform each answer into the actual numerical choice shown in the same column in Row 1.
This number should be  displayed  in the appropriate Subject's Row under the column names for each question -Q1 – Q8(See Output Sheet).

Thanks

EE3.4.xlsx
0
Question by:PDSWSS

LVL 24

Accepted Solution

I recognised this from your earlier question, and tweaked my answer to that, so now there is an array which stores the number of columns for each question:
``````Sub x()

Dim r As Range, n As Long, i As Long, j As Long, c As Long, v

v = Array(5, 5, 5, 3, 3, 3, 5, 5)

With Sheets("Sample")
.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Copy Sheets("OutputExample").Range("A2")
For n = 2 To .Range("A" & Rows.Count).End(xlUp).Row
Set r = .Cells(n, 2).Resize(, v(j))
c = 1
Do While Not IsEmpty(r(1))
i = Application.Match(1, r, 0) - 1
c = c + 1
Sheets("OutputExample").Cells(Rows.Count, c).End(xlUp)(2) = i
Set r = r.Offset(, v(j))
j = j + 1
Loop
j = 0
Next n
End With

With Sheets("OutputExample")
With .Range("B2", .Range("B2").End(xlToRight)).Offset(-1)
.Formula = "=""Q"" & column()-1"
.Value = .Value
End With
End With

End Sub
``````
0

LVL 12

Assisted Solution

This code will do what you want

Kyle
``````Sub SummarizeQuestions()
Dim QRows() As String, i As Long, j As Long
ReDim QRows(8)
QRows(1) = ("B:F")
QRows(2) = ("G:K")
QRows(3) = ("L:P")
QRows(4) = ("Q:S")
QRows(5) = ("T:V")
QRows(6) = ("W:Y")
QRows(8) = ("AE:AI")

For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To UBound(QRows)
With Sheets("OutputExample (2)").Cells(j, 1)
.Value = Cells(j, 1)
'Application.Intersect(Columns(QRows(i)), Rows(j)).Select
.Offset(, i) = WorksheetFunction.Match(1, Application.Intersect(Columns(QRows(i)), Rows(j)), 0) - 1
End With
Next i
Next j
End Sub
``````
Q-27409578-RevA.xlsm
0

Author Comment

You are good. One try worked perfectly.

Q. I have two more forms I need to transform. However, they have text in addition to a number in Row A in each column.
Would I need to delete the text for your code to work in these cases?

Q. Also would your code work in the case where  the  answers in Row A  went  in ascending and then descending order eg   12345543211234554321

Thanks
0

LVL 24

Expert Comment

1. If you mean instead of 1 the cells contain e.g. A1 then yes either your sheet or the code would have to be changed.

2. Not sure I follow, do you mean row 1, A is a column?
0

Author Comment

I sent the message above to StephenJR before I got  kgerb's solution.

Did not test kgerb's solution yet.
0

LVL 24

Expert Comment

Btw Kyle has also posted a solution so please acknowledge that.
0

LVL 24

Expert Comment

Cross-posted.
0

Author Comment

StephenJR

1. If you mean instead of 1 the cells contain e.g. A1 then yes either your sheet or the code would have to be changed.

More complex - eg  1. No increase,   2. feels talkative,  3. fairly tired,  4. very tired.  I would need code that would delete the text.
I will make a separate post.

2. Not sure I follow, do you mean row 1, A is a column?

My mistake  Row 1 not Row A. Sorry about that.

Q. CORRECTED - Also would your code work in the case where  the  answers in Row 1  went  in ascending and then descending order eg    123455432112344321
0

LVL 24

Expert Comment

All this could be catered for, I suggest you post an illustrative workbook and explain which bits might vary and how.
0

Author Comment

kgerb

Tried your code and got Runtime error '9'
Subscript out of range p

On Debug   Highlighted:        "With Sheets("OutputExample (2)").Cells(j, 1)"

Any ideas?
0

Author Comment

StephenJR

Thanks. Will post as a separate question and will wait to award points until I hear back from Kyle.
0

LVL 24

Expert Comment

Just a syntax error in Kyle's code, change to

With Sheets("OutputExample").Cells(j, 1)
0

LVL 12

Expert Comment

Stephenjr,
Thank you for correcting my code.  I created another sheet in my example workbook so I would not blow away the original values.  I forgot to change the code back.  Thanks again.

Kyle
0

Author Comment

That's very generous.  First time I have seen one expert solve a bug in another expert's code.

In this case, should I split the points?
0

LVL 24

Expert Comment

That's fine with me, thanks.
0

Author Closing Comment

Thanks for both of your solutions.
0

Author Comment

0

Write Comment

Please enter a first name

Please enter a last name

We will never share this with anyone.

Featured Post

I've recently been in need of an Excel macro that could add a letter before the text on multiple cells in an Excel document. My English is as it is, so I will try explain what it does diffrently. If you have an excel document with 2000 rows an…
Dealing with unintended Excel Active-X resizing quirks (VBA code simulates "self correction") David Miller (dlmille) Intro Not everyone is a fan of Active-X controls in spreadsheets (as opposed to the UserForm approach, the older Form controls …
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

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

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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!