VBA code with IF, cut/paste, & last column

[RLCornish]

I have a list of travel details where each row is a different leg of a travelers journey. There are common details at the beginning of the row, such as passenger name and such. In order to use the data to auto-fill a templated itinerary I need to align the legs of the journeys per passenger into a single row. Here's an example of what the data I receive looks like...

DOE/JOHN	1	19/01/17	19/01/17	Duluth, MN	Minneapolis, MN	7:00AM
DOE/JOHN	2	19/01/17	19/01/17	Minneapolis, MN	Kansas City, MO	9:55AM
DOE/JOHN	3	25/01/17	25/01/17	Kansas City, MO	Minneapolis, MN	7:49PM
DOE/JOHN	4	25/01/17	25/01/17	Minneapolis, MN	Duluth, MN	10:00PM
PICKLE/FARMER	1	31/07/17	31/07/17	Minneapolis, MN	Kansas City, MO	7:05AM
PICKLE/FARMER	2	2/08/17	2/08/17	Kansas City, MO	Minneapolis, MN	7:49PM
SMITH/MRS.	1	31/03/17	31/03/17	Madison, WI	Minneapolis, MN	6:40AM
SMITH/MRS.	2	31/03/17	31/03/17	Minneapolis, MN	Kansas City, MO	9:55AM
SMITH/MRS.	3	1/04/17	1/04/17	Kansas City, MO	Minneapolis, MN	7:49PM
SMITH/MRS.	4	1/04/17	1/04/17	Minneapolis, MN	Madison, WI	10:20PM

<colgroup><col width="145" style="width: 109pt;"><col width="80" style="width: 60pt;"><col width="115" span="5" style="width: 86pt;"></colgroup><tbody>
</tbody>

Ideally what I would have would look like this...

DOE/JOHN

1

6/08/17

6/08/17

Duluth, MN

Minneapolis, MN

7:00AM

2

6/08/17

6/08/17

Minneapolis, MN

Kansas City, MO

9:55AM

3

7/08/17

7/08/17

Kansas City, MO

Minneapolis, MN

7:49PM

4

7/08/17

7/08/17

Minneapolis, MN

Duluth, MN

10:00PM

PICKLE/FARMER

1

31/07/17

31/07/17

Minneapolis, MN

Kansas City, MO

7:05AM

2

2/08/17

2/08/17

Kansas City, MO

Minneapolis, MN

7:49PM

SMITH/MRS.

1

31/07/17

31/07/17

Madison, WI

Minneapolis, MN

6:40AM

2

31/07/17

31/07/17

Minneapolis, MN

Kansas City, MO

9:55AM

3

1/08/17

1/08/17

Kansas City, MO

Minneapolis, MN

7:49PM

4

1/08/17

1/08/17

Minneapolis, MN

Madison, WI

10:20PM

<colgroup><col width="168" style="width:126pt"> <col width="20" style="width:15pt"> <col width="85" style="width:64pt" span="2"> <col width="149" style="width:112pt"> <col width="152" style="width:114pt"> <col width="75" style="width:56pt"> <col width="20" style="width:15pt"> <col width="85" style="width:64pt" span="2"> <col width="152" style="width:114pt" span="2"> <col width="75" style="width:56pt"> <col width="20" style="width:15pt"> <col width="74" style="width:56pt" span="2"> <col width="152" style="width:114pt"> <col width="149" style="width:112pt"> <col width="75" style="width:56pt"> <col width="20" style="width:15pt"> <col width="74" style="width:56pt" span="2"> <col width="149" style="width:112pt"> <col width="116" style="width:87pt"> <col width="86" style="width:65pt"> </colgroup><tbody>
</tbody>

I was thinking something along the lines of IF name field matches cell above cut cells 8 thru 13 of current row, offset up 1 row, find first empty cell to the right, then paste. IF does not match cell above, drop to cell in col A and repeat. Loop thru each row until end.

If you have anything idea of how to accomplish this, I'm good with that, but this was what my mind conceived.

Any help would be appreciated!

 

[mse330]

RLCornish, try this code - assuming your current sheet structure is exactly the same as shown above. If you need any further help let me know

Sub test()

Dim PassName As String, Seq As Integer, LastCol As Single, LastRow As Single, OrgRg As Range, NewRg As Range

LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = 7

For x = 2 To LastRow
    PassName = Cells(x, 1).Value
    Seq = ActiveSheet.Range("B" & x).Value
        If PassName = Cells(x, 1).Value And Seq > 1 Then
            Set OrgRg = Range("B" & x & ":G" & x)
            Set NewRg = Range(Cells(x - Seq + 1, (Seq * 6) - 4), Cells(x - Seq + 1, (Seq * 6) + 1))
                If ((Seq * 6) + 1) > LastCol Then LastCol = ((Seq * 6) + 1)
                NewRg.Value = OrgRg.Value
        End If
Next x

Set NewRg = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))

NewRg.Sort Key1:=Range("B2:B" & LastRow), Order1:=xlAscending, Header:=xlYes

Dim FindFirst As Single
FindFirst = Application.WorksheetFunction.Match(2, Range("B2:B" & LastRow), 0) + 1

Rows(FindFirst & ":" & LastRow + 1).EntireRow.Delete

End Sub