Need help on this....thanks

  • Thread starter Thread starter Paul
  • Start date Start date
P

Paul

I have an Excel worksheet which stored a survey outcome of over 1200
members. There are over 30 questions in the survey and the first column
captured the member ID. The problem is 3 of the survey questions that allow
multiple answers, instead the answer for those three questions are captured
in seperate column, the answers are stored in a single column and it makes
it very difficult to analysis those result. As a result I created
addittional columns depending on the total number of the answers available
for that question and assign the result manually to that column. It is very
time consuming and I wonder if I can create a macro to loop through each
member on those three questions and assign the result(s) to the new created
columns.

The format of the existing Excel worksheet is as follow; * denote as
multiple answer allowable
for example: Q2 has 4 answer choices, car, plane, boat and people and in the
order of the answer in the survey
Q3 has 5 answer choices, power point, excel, access,
word and outlook and in the order of the answer in the survey

memberID----Q1-------*Q2-------*Q3---------Q4
123456 yes car power point yes
plane excel
access
word
234578 no plane excel no
boat word
people
784528 yes people power point yes
access
outlook

What I did to the existing Excel worhsheet I changed the column name from
*Q2 to the first available answer which is car for the Q2 and added three
addittional columns, plane, boat and people next to the column "car" and so
on for *Q3 as follow:

memberID----Q1----car----plane----boat----people----powerpoint----excel----access----word----outlook----Q4
123456 yes car plane
power point excel access word yes
234578 no plane boat people
excel word no
784529 yes people
powerpoint access outlook yes


What I want to achieve here is ONE ROW of record for each of the
member survey answer. I need a macro to loop through each member and assign
the survey result to the proper column and delete the "Blank" rows at the
end. Thanks.
 
You have an active thread in .programming.
I have an Excel worksheet which stored a survey outcome of over 1200
members. There are over 30 questions in the survey and the first column
captured the member ID. The problem is 3 of the survey questions that allow
multiple answers, instead the answer for those three questions are captured
in seperate column, the answers are stored in a single column and it makes
it very difficult to analysis those result. As a result I created
addittional columns depending on the total number of the answers available
for that question and assign the result manually to that column. It is very
time consuming and I wonder if I can create a macro to loop through each
member on those three questions and assign the result(s) to the new created
columns.

The format of the existing Excel worksheet is as follow; * denote as
multiple answer allowable
for example: Q2 has 4 answer choices, car, plane, boat and people and in the
order of the answer in the survey
Q3 has 5 answer choices, power point, excel, access,
word and outlook and in the order of the answer in the survey

memberID----Q1-------*Q2-------*Q3---------Q4
123456 yes car power point yes
plane excel
access
word
234578 no plane excel no
boat word
people
784528 yes people power point yes
access
outlook

What I did to the existing Excel worhsheet I changed the column name from
*Q2 to the first available answer which is car for the Q2 and added three
addittional columns, plane, boat and people next to the column "car" and so
on for *Q3 as follow:

memberID----Q1----car----plane----boat----people----powerpoint----excel----access----word----outlook----Q4
123456 yes car plane
power point excel access word yes
234578 no plane boat people
excel word no
784529 yes people
powerpoint access outlook yes

What I want to achieve here is ONE ROW of record for each of the
member survey answer. I need a macro to loop through each member and assign
the survey result to the proper column and delete the "Blank" rows at the
end. Thanks.
Click to expand...
 
assuming memberID in A1, try this one. this will put data into new worksheet
named "temp".
Any cells between memberIDs, if exist, must be blank. if not, this will not
work.

Sub testex()
Dim acwk As Worksheet, tmpwk As Worksheet
Dim st As Range, stt As Range, en As Range
Dim k As Long, cl As Long, cll As Long, last As Long
Dim i As Long
Dim p
Dim pos()
Dim data()

cl = Range("A1").End(xlToRight).Column
ReDim data(cl)
ReDim pos(cl)
'Change data(no) below to your data, (no) means column number
data(3) = Array("car", "plane", "boat", "pepole")
data(4) = Array("power point", "excel", "access", "word", "outlook")
pos(0) = 0
For i = 1 To cl
If IsEmpty(data(i - 1)) Then
pos(i) = pos(i - 1) + 1
Else
pos(i) = pos(i - 1) + UBound(data(i - 1)) + 1
End If
Next

On Error Resume Next
Set acwk = ActiveSheet
Set tmpwk = worksheets("temp")
If tmpwk Is Nothing Then
Set tmpwk = worksheets.Add(after:=ActiveSheet)
tmpwk.Name = "temp"
End If
tmpwk.Cells.ClearContents
acwk.Select
On Error GoTo 0
last = Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
cl = pos(UBound(pos)) + 1
For i = 1 To Range("A1").End(xlToRight).Column
k = 2
Set st = Range("A2")
Do
Set en = st.End(xlDown)
If en.Row > last Then
Set en = Cells(last + 1, "A")
End If
Set stt = st.Offset(0, i - 1)
cll = cl + 1
Do While (stt.Row < en.Row)
If Not IsEmpty(data(i)) Then
p = Application.Match(stt.Value, data(i), 0)
If IsNumeric(p) Then
p = p - 1
tmpwk.Cells(k, pos(i) + p) = stt.Value
Else
tmpwk.Cells(k, cll) = stt.Value
cll = cll + 1
End If
Else
tmpwk.Cells(k, pos(i)) = stt.Value
Exit Do
End If
Set stt = stt.Offset(1, 0)
Loop
Set st = en
k = k + 1
Loop While (en.Row <= last)
Next
End Sub

keizi
 
Sorry. my testex will not work correctly. try this new one.

Sub testex1()
Dim acwk As Worksheet, tmpwk As Worksheet
Dim st As Range, stt As Range, en As Range
Dim k As Long, cl As Long, cll As Long, last As Long
Dim i As Long
Dim p
Dim pos()
Dim data()

cl = Range("A1").End(xlToRight).Column
ReDim data(cl)
ReDim pos(cl)
'Change data(no) below to your data, (no) means column number
data(3) = Array("car", "plane", "boat", "pepole")
data(4) = Array("power point", "excel", "access", "word", "outlook")
pos(0) = 0
For i = 1 To cl
If IsEmpty(data(i - 1)) Then
pos(i) = pos(i - 1) + 1
Else
pos(i) = pos(i - 1) + UBound(data(i - 1)) + 1
End If
Next

On Error Resume Next
Set acwk = ActiveSheet
Set tmpwk = worksheets("temp")
If tmpwk Is Nothing Then
Set tmpwk = worksheets.Add(after:=ActiveSheet)
tmpwk.Name = "temp"
End If
tmpwk.Cells.ClearContents
acwk.Select
On Error GoTo 0
last = Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
cl = pos(UBound(pos)) + 1
For i = 1 To Range("A1").End(xlToRight).Column
k = 2
Set st = Range("A2")
Do
If IsEmpty(st.Offset(1, 0)) Then
Set en = st.End(xlDown)
Else
Set en = st.Offset(1, 0)
End If
If en.Row > last Then
Set en = Cells(last + 1, "A")
End If
Set stt = st.Offset(0, i - 1)
cll = cl + 1
Do While (stt.Row < en.Row)
If Not IsEmpty(data(i)) Then
p = Application.Match(stt.Value, data(i), 0)
If IsNumeric(p) Then
p = p - 1
tmpwk.Cells(k, pos(i) + p) = stt.Value
Else
tmpwk.Cells(k, cll) = stt.Value
cll = cll + 1
End If
Else
tmpwk.Cells(k, pos(i)) = stt.Value
Exit Do
End If
Set stt = stt.Offset(1, 0)
Loop
Set st = en
k = k + 1
Loop While (en.Row <= last)
Next
End Sub

keizi
 
Try this, adjust to suit.
We have only done Q2, Q3 is your exercise.
Pack the lines afterwards.

Sub m()
lrow = Cells(Rows.Count, "D").End(xlUp).Row
Set rng = Range(Cells(1, 1), Cells(lrow, "A"))

For Each c In rng
v = Trim(c)
If v <> "" Then
rownr = c.Row
c.Copy Cells(rownr, "J")
c.Offset(0, 1).Copy Cells(rownr, "K")
If c.Offset(0, 2) Like "car*" Then colnr = 12
If c.Offset(0, 2) Like "plane*" Then colnr = 13
If c.Offset(0, 2) Like "boat*" Then colnr = 14
c.Offset(0, 2).Copy Cells(rownr, colnr)
c.Offset(0, 3).Copy Cells(rownr, 15)
c.Offset(0, 4).Copy Cells(rownr, 16)
Else
If c.Offset(0, 2) Like "car*" Then colnr = 12
If c.Offset(0, 2) Like "plane*" Then colnr = 13
If c.Offset(0, 2) Like "boat*" Then colnr = 14
If c.Offset(0, 2) <> "" Then
c.Offset(0, 2).Copy Cells(rownr, colnr)
End If
c.Offset(0, 3).Copy Cells(rownr, 15)
End If
Next c
End Sub
 
Back
Top