Transpose Rows to Columns based on Like Data

[web1]

Hi,

I have a dataset that is organized in rows and I need it transposed to
columns based on like/similar data in specific row fields (ID in the
example). For example

ID Quest Answer
1 Q1 A1
1 Q2 A2
2 Q1 A1

Desired result
=========

ID Q1 Q2
1 A1 A2
2 A1

The actual table is 1000's of rows. The number of questions and their
answers would vary by id. Can this be done with arrays? Any VBA code
would be greatly appreciated.

Thanks,

Manish

 

[Joel]

The macro below will crreate a summary sheet to perform your task. The code
use sheet 1 to contain your dataset. The data set worksheet has a header
row (like your posting) with the three columns startig in column A. You need
to create a blank worksheet called "Summary" where the results get posted.

Sub summary()

SummaryColCount = 2
SummaryRowCount = 2
With Sheets("Sheet1")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For RowCount = 2 To LastRow
ID = .Cells(RowCount, "A")
Question = .Cells(RowCount, "B")
Answer = .Cells(RowCount, "C")

With Sheets("Summary")
'see if id if already in Summary
Set C = .Columns(1).Find( _
what:=ID, _
LookIn:=xlValues)

If C Is Nothing Then
.Cells(SummaryRowCount, "A").Value = ID
RowNumber = SummaryRowCount
SummaryRowCount = SummaryRowCount + 1
Else
RowNumber = C.Row
End If

'see if question if already in Summary
Set C = .Rows(1).Find( _
what:=Question, _
LookIn:=xlValues)

If C Is Nothing Then
.Cells(1, SummaryColCount).Value = Question
ColNumber = SummaryColCount
SummaryColCount = SummaryColCount + 1
Else
ColNumber = C.Column
End If
.Cells(RowNumber, ColNumber).Value = Answer
End With
Next RowCount
End With
End Sub

 

[web1]

The macro below will crreate a summary sheet to perform your task. The code
use sheet 1 to contain your dataset. The data set worksheet has a header
row (like your posting) with the three columns startig in column A. You need
to create a blank worksheet called "Summary" where the results get posted.

Sub summary()

SummaryColCount = 2
SummaryRowCount = 2
With Sheets("Sheet1")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For RowCount = 2 To LastRow
ID = .Cells(RowCount, "A")
Question = .Cells(RowCount, "B")
Answer = .Cells(RowCount, "C")

With Sheets("Summary")
'see if id if already in Summary
Set C = .Columns(1).Find( _
what:=ID, _
LookIn:=xlValues)

If C Is Nothing Then
.Cells(SummaryRowCount, "A").Value = ID
RowNumber = SummaryRowCount
SummaryRowCount = SummaryRowCount + 1
Else
RowNumber = C.Row
End If

'see if question if already in Summary
Set C = .Rows(1).Find( _
what:=Question, _
LookIn:=xlValues)

If C Is Nothing Then
.Cells(1, SummaryColCount).Value = Question
ColNumber = SummaryColCount
SummaryColCount = SummaryColCount + 1
Else
ColNumber = C.Column
End If
.Cells(RowNumber, ColNumber).Value = Answer
End With
Next RowCount
End With
End Sub










- Show quoted text -

Thanks a lot!