extract text and consolidate

[Birdy01962]

I have a list

(A1) is Job Description,
(A2) Cost items (Materials and Labour)
(A3) Qty (Items and Hours)

from this list I would like to extract all labour hours together with each Job Description into another work sheet. So far I have identified all "Lab" lines but where do I go to extract and consolidate into new sheet.

Job Description	Material	Quantity		identify "Lab"
Site Preparation	Skip Hire	2		NO
Site Preparation	Digger/Day	2		NO
Site Preparation	LABOUR - Day Rate Paul	2		OK
Site Preparation	LABOUR - Day Rate Staff	2		OK
Footings	Cement	6		NO
Footings	Ballast / tonne	3		NO
Footings	LABOUR - Day Rate Paul	2		OK
Wall	Brickwork / 100	3		NO
Wall	LABOUR - Day Rate Paul	3		OK
Cleaning	LABOUR - Day Rate Paul	4		OK
What I require
				No of Hours
Site Preparation	LABOUR - Day Rate Paul (plus Labour - Day Rate Staff)	4
Footings	LABOUR - Day Rate Paul			2
Wall	LABOUR - Day Rate Paul			3
Cleaning	LABOUR - Day Rate Paul			4

<tbody>
</tbody>

 

[MickG]

Try this for Results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG22Nov50
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Ray [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Left(Dn.Offset(, 1).Value, 6) = "LABOUR" And Dn.Value <> "" [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Value, Array(Dn.Value, Dn.Offset(, 1).Value, Dn.Offset(, 2).Value)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Dn.Value)
            [COLOR="Navy"]If[/COLOR] InStr(Q(1), Dn.Offset(, 1).Value) = 0 [COLOR="Navy"]Then[/COLOR]
                Q(1) = Q(1) & " + " & Dn.Offset(, 1).Value
            [COLOR="Navy"]End[/COLOR] If
            Q(2) = Q(2) + Dn.Offset(, 2).Value
            .Item(Dn.Value) = Q
        [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Ray = .items: n = .Count
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1")
        .Resize(, 3).Value = Array("Job", "Labour", "Qty")
        .Offset(1).Resize(n, 3).Value = Application.Transpose(Application.Transpose(Ray))
        .Resize(n + 1, 3).Columns.AutoFit
        .Resize(n + 1, 3).Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Birdy01962]

Thanks Mick for your help and suggestion above however when I run it produces a "run time error 13 Type mismatch" after "sheet2"....Offset(1).Resize).....

After the error "Sheet2" has the headings "Job","Labour"and "Qty" only - no Labour line items.

Can you suggest where its going wrong.

Regards Birdy01962

 

[MickG]

Have a look at this example of your data.
If this works and your Actual data appears to be the problem.
Repost some more relevant data and I'll have another go !!!
https://app.box.com/s/8ata2gd2kwiqpbfo1blj2n3bqvcsu1jq