Selecting data based on cell entry higher in column

Paul at GTS

Board Regular
Joined
May 17, 2004
Messages
56
Office Version
  1. 365
Platform
  1. Windows
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
1ORIGINAL LIST
2Apartment: 91,103
3Pre- insulated 204x60
417m straight
58x male collar
68x brackets
72x 90 horizontal
83x 45 horizontal
92x elbow to 150dia
10204x60 pvc
1127m straight
1213x male collar
1314x brackets
146x 90 horizontal
154x fire collars
161x t piece
173x square to 150dia
184x elbow to 150dia
19150dia pvc
205m straight
213x split rings
221x 90 bend
234x 45 bend
241x t piece
252x metal Hi Flow air brick 400 long
264x Punka valve
27Apartment: 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
1ORIGINAL LIST
2Apartment: 91,103
3Pre- insulated 204x60
417m 204x60 Insulated straight
58x 204x60 Insulated male collar
68x 204x60 Insulated brackets
72x 90 204x60 Insulated horizontal
83x 45 204x60 Insulated horizontal
92x 204x60 Insulated elbow to 150dia
10204x60 pvc
1127m 204x60 straight
1213x 204x60 male collar
1314x 204x60 brackets
146x 204x60 90 horizontal
154x 204x60 fire collars
161x 204x60 t piece
173x 204x60 square to 150dia
184x 204x60 elbow to 150dia
19150dia pvc
205m 150dia pvc straight
213x 150dia pvc split rings
221x 150dia pvc 90 bend
234x 150dia pvc 45 bend
241x 150dia pvc t piece
252x 150dia pvc metal Hi Flow air brick 400 long
264x 150dia pvc Punka valve
Sheet2


Thanks
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
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.

Code:
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
 
Upvote 0
You're welcome. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,144
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top