Selecting data based on cell entry higher in column

[Paul at GTS]

Hi, need help with the following. Have a workbook with 1200 lines and 4 columns.
Its a list of building material for a office block split by size. For each size there are a number of different products listed. These are then replicated over the 49 floors of the building. Sample below :

Book1
	A
1	ORIGINAL LIST
2	Apartment: 91,103
3	Pre- insulated 204x60
4	17m straight
5	8x male collar
6	8x brackets
7	2x 90 horizontal
8	3x 45 horizontal
9	2x elbow to 150dia
10	204x60 pvc
11	27m straight
12	13x male collar
13	14x brackets
14	6x 90 horizontal
15	4x fire collars
16	1x t piece
17	3x square to 150dia
18	4x elbow to 150dia
19	150dia pvc
20	5m straight
21	3x split rings
22	1x 90 bend
23	4x 45 bend
24	1x t piece
25	2x metal Hi Flow air brick 400 long
26	4x Punka valve
27	Apartment: 87,99
Sheet1

What id like to achieve is this, where the item lines have been pre fixed by the header shown in colours - if that makes sence.

Book1
	A
1	ORIGINAL LIST
2	Apartment: 91,103
3	Pre- insulated 204x60
4	17m 204x60 Insulated straight
5	8x 204x60 Insulated male collar
6	8x 204x60 Insulated brackets
7	2x 90 204x60 Insulated horizontal
8	3x 45 204x60 Insulated horizontal
9	2x 204x60 Insulated elbow to 150dia
10	204x60 pvc
11	27m 204x60 straight
12	13x 204x60 male collar
13	14x 204x60 brackets
14	6x 204x60 90 horizontal
15	4x 204x60 fire collars
16	1x 204x60 t piece
17	3x 204x60 square to 150dia
18	4x 204x60 elbow to 150dia
19	150dia pvc
20	5m 150dia pvc straight
21	3x 150dia pvc split rings
22	1x 150dia pvc 90 bend
23	4x 150dia pvc 45 bend
24	1x 150dia pvc t piece
25	2x 150dia pvc metal Hi Flow air brick 400 long
26	4x 150dia pvc Punka valve
Sheet2

Thanks

 

[igold]

Hi, this code works on your above request. That said, there is no set pattern on what you colored headers(or materials) change to in the body of the description. For instance "Pre- insulated 204x60" becomes "204x60 Insulated" while "204x60 PVC" becomes "204x60", etc. You will have to use two columns to enter what your transformations are. I used columns Y & Z. So Cell Y1 = Pre- insulated 204x60 and Celll Z1 = "204x60 Insulated". Do this all the way down columns Y & Z with as many colored materials you have to transform into your list.

If you do not want to use columns Y & Z, I highlighted in Red the line you will have to change. I hope this makes sense.

Sub ChangeList()


    Dim brk, Lst, p, lines
    Dim i As Long, ct As Long, pos As Long, x As Long, R As Long, k As Long
    Dim rws As String
    Dim rng As Range, C As Range
    Dim str()
    
    Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If rng.Cells(rng.Cells.Count) Like "Apartment*" Then rng.Rows(rng.Rows.Count).Delete
[COLOR=#ff0000]    brk = Range("Y1:Z" & Cells(Rows.Count, 25).End(xlUp).Row)[/COLOR]
    Lst = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    Lst = Application.Transpose(Lst)
    
    str = Range("Y1:Y" & Cells(Rows.Count, 25).End(xlUp).Row).Value2
    
     For i = LBound(Lst) To UBound(Lst)
        p = Application.Match(Lst(i), str, False)
        If Not IsError(p) Then
            rws = rws & "," & i
        End If
    Next
    rws = Mid(rws, 2)
    lines = Split(rws, ",")
    
    For i = LBound(Lst) To UBound(Lst)
        p = Application.Match(Lst(i), str, False)
        If Not IsError(p) Then
            x = p
            ct = i
            Do
                If ct = UBound(Lst) Then GoTo endsub
                pos = InStr(Lst(ct + 1), " ")
                Lst(ct + 1) = Left(Lst(ct + 1), pos) & brk(x, 2) & Mid(Lst(ct + 1), pos)
                ct = ct + 1
                p = Application.Match(Lst(ct), str, False)
                    If R + 1 > UBound(lines) Then
                        k = k + 1
                        ct = lines(UBound(lines)) + k
                        GoTo lsect
                    End If
                    If ct = lines(R + 1) - 1 Then
                        R = R + 1
                        Exit Do
                    End If
lsect:
            Loop
        End If
    Next
endsub:


    rng.Copy
    With Worksheets("Sheet2").Range("A1")
        .Resize(UBound(Lst)) = Application.Transpose(Lst)
        .PasteSpecial xlPasteFormats
    End With
    Application.CutCopyMode = False
    Worksheets("Sheet2").Select
    Range("A1").Select
    
End Sub

 

[Paul at GTS]

Thanks, works well

 

[igold]

You're welcome. Thanks for the feedback.