transforming poll data from rows to colums

[ulfb]

Hi,
I need to rearrange data on two sheets to a third. As a amateur I would
appreciate any help!
Thank you
Ulf


Sheet01 contains "data" replies:
ReplyId QuestNo QuestName QuestText QuestAltValue
6402 1 Member? 1 Yes
6402 3 Prefers? 3 Milk
6403 1 Member? 2 No
6403 3 Prefers? 1 Beer
6403 4 Age? 55

Sheet02 contains "text" replies:
ReplyId QuestNo QuestName QuestText QuestAltValue
6402 2 Name? steve
6402 5 City? London
6403 2 Name? john
6403 5 City? Paris

What I need is Sheet03 with one row per ReplyId - and one column per QuestNo

ReplyId Member? Name? Prefers? Age? City?
6402 1 Yes Steve 3 Milk London
6403 2 No John 1 Beer 55 Paris

 

[Joel]

I assumed there were header rows on all 3 sheets as shown in your data before
the program is run. The 3 sheet names are sheet1, sheet2,sheet3. Program
uses header row on sheet 3 for looking up the questions. Adding more columns
to sheet3 will not require any changes to the program.

Sub combinedata()

Call CombineSheet("sheet1")
Call CombineSheet("sheet2")

End Sub
Sub CombineSheet(ByVal SheetName As String)

'skip header row

With Sheets("Sheet3")
Sh3RowCount = .Cells(Rows.Count, "A"). _
End(xlUp).Row
LastCol = .Cells(1, Columns.Count). _
End(xlToLeft).Column
Set QuestRange = .Range( _
.Cells(1, "B"), .Cells(1, LastCol))
End With

With Sheets(SheetName)
RowCount = 2
Do While .Cells(RowCount, "A") <> ""
'find ReplyId
ReplyID = .Cells(RowCount, "A").Value
Question = .Cells(RowCount, "C").Value
Answer = Trim(.Cells(RowCount, "D").Value)
Answer = Answer & " " & _
Trim(.Cells(RowCount, "E").Value)
With Sheets("Sheet3")
Set Sh3IDRange = .Range( _
.Cells(2, "A"), _
.Cells(Sh3RowCount, "A"))
Set c1 = Sh3IDRange.Find( _
what:=ReplyID, _
LookIn:=xlValues)
If Not c1 Is Nothing Then
InsertRow = c1.Row
Else
Sh3RowCount = Sh3RowCount + 1
InsertRow = Sh3RowCount
.Cells(InsertRow, "A") = _
ReplyID
End If

Set c2 = QuestRange.Find( _
what:=Question, _
LookIn:=xlValues)
If Not c2 Is Nothing Then
.Cells(InsertRow, c2.Column).Value = _
Answer
Else
MsgBox ("Could Not find question : " & _
Question)
End If

End With
RowCount = RowCount + 1
Loop

End With
End Sub

 

[ulfb]

Thank you Joel

That helps a lot! However, sheet3 has no headers since questions vary, both
i number and contents. Headers need to be created from unique entries in
QuestName, sheet1 and sheet2
Any suggestions for that?
Ulf

 

[Joel]

I made a small change to create the header row on sheet 3

Sub combinedata()

With Sheets("Sheet3")
.Cells(1, "A") = "ReplyId"
End With
Call CombineSheet("sheet1")
Call CombineSheet("sheet2")

End Sub
Sub CombineSheet(ByVal SheetName As String)

'skip header row


With Sheets("Sheet3")
Sh3RowCount = .Cells(Rows.Count, "A"). _
End(xlUp).Row
LastCol = .Cells(1, Columns.Count). _
End(xlToLeft).Column
Set QuestRange = .Range( _
.Cells(1, "A"), .Cells(1, LastCol))
End With

With Sheets(SheetName)
RowCount = 2
Do While .Cells(RowCount, "A") <> ""
'find ReplyId
ReplyID = .Cells(RowCount, "A").Value
Question = .Cells(RowCount, "C").Value
Answer = Trim(.Cells(RowCount, "D").Value)
Answer = Answer & " " & _
Trim(.Cells(RowCount, "E").Value)
With Sheets("Sheet3")
Set Sh3IDRange = .Range( _
.Cells(2, "A"), _
.Cells(Sh3RowCount, "A"))
Set c1 = Sh3IDRange.Find( _
what:=ReplyID, _
LookIn:=xlValues)
If Not c1 Is Nothing Then
InsertRow = c1.Row
Else
Sh3RowCount = Sh3RowCount + 1
InsertRow = Sh3RowCount
.Cells(InsertRow, "A") = _
ReplyID
End If

Set c2 = QuestRange.Find( _
what:=Question, _
LookIn:=xlValues)
If Not c2 Is Nothing Then
.Cells(InsertRow, c2.Column).Value = _
Answer
Else
LastCol = LastCol + 1
.Cells(1, LastCol).Value = _
Question
.Cells(InsertRow, LastCol).Value = _
Answer
Set QuestRange = .Range( _
.Cells(1, "A"), .Cells(1, LastCol))
End If

End With
RowCount = RowCount + 1
Loop

End With
End Sub

 

[ulfb]

Thank you, I am very grateful!
Ulf

I made a small change to create the header row on sheet 3

Sub combinedata()

With Sheets("Sheet3")
.Cells(1, "A") = "ReplyId"
End With
Call CombineSheet("sheet1")
Call CombineSheet("sheet2")

End Sub
Sub CombineSheet(ByVal SheetName As String)

'skip header row


With Sheets("Sheet3")
Sh3RowCount = .Cells(Rows.Count, "A"). _
End(xlUp).Row
LastCol = .Cells(1, Columns.Count). _
End(xlToLeft).Column
Set QuestRange = .Range( _
.Cells(1, "A"), .Cells(1, LastCol))
End With

With Sheets(SheetName)
RowCount = 2
Do While .Cells(RowCount, "A") <> ""
'find ReplyId
ReplyID = .Cells(RowCount, "A").Value
Question = .Cells(RowCount, "C").Value
Answer = Trim(.Cells(RowCount, "D").Value)
Answer = Answer & " " & _
Trim(.Cells(RowCount, "E").Value)
With Sheets("Sheet3")
Set Sh3IDRange = .Range( _
.Cells(2, "A"), _
.Cells(Sh3RowCount, "A"))
Set c1 = Sh3IDRange.Find( _
what:=ReplyID, _
LookIn:=xlValues)
If Not c1 Is Nothing Then
InsertRow = c1.Row
Else
Sh3RowCount = Sh3RowCount + 1
InsertRow = Sh3RowCount
.Cells(InsertRow, "A") = _
ReplyID
End If

Set c2 = QuestRange.Find( _
what:=Question, _
LookIn:=xlValues)
If Not c2 Is Nothing Then
.Cells(InsertRow, c2.Column).Value = _
Answer
Else
LastCol = LastCol + 1
.Cells(1, LastCol).Value = _
Question
.Cells(InsertRow, LastCol).Value = _
Answer
Set QuestRange = .Range( _
.Cells(1, "A"), .Cells(1, LastCol))
End If

End With
RowCount = RowCount + 1
Loop

End With
End Sub