How to determine the end range in my code....

[Paul]

With the format of the Excel worksheet as follow:
memberID----Q1-------*Q2-------Q4
123456 yes car yes
plane
people
234578 no boat no
people
784528 yes car yes
boat

I want to transform it to the following format:
memberID----Q1----car----plane----boat----people----Q4
123456 yes car plane people yes
234578 no boat people no
784529 yes car boat
yes

The following is the code I created, somehow I can't figure out how to set
the end range to the next member ID for the 'InnerNumRows"
Sub Test()
Dim x As Integer
Dim y As Integer
' Set numrows = number of rows of data, use the column with the maximum
of rows.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.Count
Debug.Print NumRows
' Select first line of data.
Range("A2").Select
For x = 1 To NumRows
' Number of rows to the next member ID.
InnerNumRows = Range(ActiveCell, ActiveCell.Next(4)).Rows.Count
Debug.Print InnerNumRows
For y = 1 To InnerNumRows
' Check active cell for search value.
Select Case ActiveCell.Offset(0, 2).Value
Case "car"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 2)
Case "plane"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 3)
Case "boat"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 4)
Case "people"
ActiveCell.Offset(0, 2).Cut
Destination:=ActiveCell.Offset(1 - y, 5)
End Select
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Next
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next

End Sub

Thanks

 

[Joel]

Paul: I don't think yu need both X and Y. Just use the X variable. Every
member has an ID which is the total number of rows which is yuor range.
when looking at the Inner columns just skip cells that don't have any any
data filled. You can use Isblank to skip these rows. but your Case
statement will automatically do this for you.

 

[Joel]

You don't need a Y variable. You are copying the data within the same row.
Both your source and destination is Row X.

Do delete rows you do need two counters
One counter is a loop count to to count the number of iteration you need to
go through the loop which is the Maximum number of rows. the second counter
is a row counter. the code would look like this

RowCounter = 1
For x = 1 To NumRows

if car or boat or plane or people then
Copy from RowCounter to RowCounter
RowCounter = RowCounter + 1
else
Delete Row(Rowcounter) - don't increase row counter
end if
Next x

 

[Paul]

Thanks Joel. It will not work without the Y variable since I need this Y
variable to establish the base ROW location on each member for the "Cut and
Paste" operation for the paste cells Row location. by taking out the Y
variable all the paste cells go to the same destination Row position at
"A2". The number of rows between two members can be from 1, if the first
member do not have multiple answer for that question as shown below, to many
rows.

With the format of the Excel worksheet as follow:
memberID----Q1-------*Q2-------Q4
123456 yes car yes
234578 no boat no

I wonder if it is possible to detect the number of the inner rows for the
two adjacent members by the changing on the member id on the first column.
Also how do I delete all the Blank rows afterward.

Thanks

 

[Trevor Shuttleworth]

Paul

try this:

Sub ReformatData()

Dim LastRow As Long
Dim i As Long
Dim BaseRange As Range
Dim DeleteStack As Range

LastRow = Range("C65536").End(xlUp).Row

Range("C1") = "car"
Range("D1") = "plane"
Range("E1") = "boat"
Range("F1") = "people"
Range("G1") = "Q4"

For i = 2 To LastRow
If Range("A" & i).Value <> "" Then
' remember which row to store the data
Set BaseRange = Range("A" & i)
' and make some space for it
Range("D" & i).Resize(1, 3).Insert shift:=xlToRight
' move the data to the base row
Select Case Range("C" & i)
Case "car": BaseRange.Offset(0, 2).Value = "car"
Case "plane": BaseRange.Offset(0, 3).Value = "plane": _
BaseRange.Offset(0, 2).Value = ""
Case "boat": BaseRange.Offset(0, 4).Value = "boat": _
BaseRange.Offset(0, 2).Value = ""
Case "people": BaseRange.Offset(0, 5).Value = "people": _
BaseRange.Offset(0, 2).Value = ""
End Select
Else
' stack up the rows to delete later
If DeleteStack Is Nothing Then
Set DeleteStack = Range("A" & i)
Else
Set DeleteStack = Union(DeleteStack, Range("A" & i))
End If
' move the data to the base row
Select Case Range("C" & i)
Case "car": BaseRange.Offset(0, 2).Value = "car"
Case "plane": BaseRange.Offset(0, 3).Value = "plane"
Case "boat": BaseRange.Offset(0, 4).Value = "boat"
Case "people": BaseRange.Offset(0, 5).Value = "people"
End Select
End If
Next 'i

If Not DeleteStack Is Nothing Then
DeleteStack.EntireRow.Delete
End If

End Sub

It's very specific, based on your data so it's not very scaleable ... but if
it does what you want.

Hopefull, it will give you an approach.

Regards

Trevor

 

[Danka]

Thanks..It works and I like to apply to my Excel worksheet which has 7800
rows and 192 columns. I need to apply this to five of the multiple answer
questions.

I used your code to test on my example, the last column "Q4" cells offset 2
columns to the right. Also if I do not want to delete the blank rows in
between the member id as there are alot of linked cell in the worksheet and
it may upset the linkage.

Also I wonder if it is easy to make it works on more than one multiple
answer questions using this code.

Thanks

 

[Trevor Shuttleworth]

Also if I do not want to delete the blank rows

Just delete the code that stores the addresses of the rows and deletes them

Dim DeleteStack As Range
:
' stack up the rows to delete later
If DeleteStack Is Nothing Then
Set DeleteStack = Range("A" & i)
Else
Set DeleteStack = Union(DeleteStack, Range("A" & i))
End If
:
If Not DeleteStack Is Nothing Then
DeleteStack.EntireRow.Delete
End If

With regard to the other questions, you'll need to adapt the code. As I
said, it's not easily scalable. No reason why you can't just copy the code
and modify/repeat it. Try it and see.

Regards

Trevor