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.

[TABLE="width: 522"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Job Description[/TD]
[TD]Material[/TD]
[TD]Quantity[/TD]
[TD][/TD]
[TD]identify "Lab"[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Site Preparation[/TD]
[TD]Skip Hire[/TD]
[TD]2[/TD]
[TD][/TD]
[TD]NO[/TD]
[/TR]
[TR]
[TD]Site Preparation[/TD]
[TD]Digger/Day[/TD]
[TD]2[/TD]
[TD][/TD]
[TD]NO[/TD]
[/TR]
[TR]
[TD]Site Preparation[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD]2[/TD]
[TD][/TD]
[TD]OK[/TD]
[/TR]
[TR]
[TD]Site Preparation[/TD]
[TD]LABOUR - Day Rate Staff[/TD]
[TD]2[/TD]
[TD][/TD]
[TD]OK[/TD]
[/TR]
[TR]
[TD]Footings[/TD]
[TD]Cement[/TD]
[TD]6[/TD]
[TD][/TD]
[TD]NO[/TD]
[/TR]
[TR]
[TD]Footings[/TD]
[TD]Ballast / tonne[/TD]
[TD]3[/TD]
[TD][/TD]
[TD]NO[/TD]
[/TR]
[TR]
[TD]Footings[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD]2[/TD]
[TD][/TD]
[TD]OK[/TD]
[/TR]
[TR]
[TD]Wall[/TD]
[TD]Brickwork / 100[/TD]
[TD]3[/TD]
[TD][/TD]
[TD]NO[/TD]
[/TR]
[TR]
[TD]Wall[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD]3[/TD]
[TD][/TD]
[TD]OK[/TD]
[/TR]
[TR]
[TD]Cleaning[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD]4[/TD]
[TD][/TD]
[TD]OK[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]What I require[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]No of Hours[/TD]
[/TR]
[TR]
[TD]Site Preparation[/TD]
[TD="colspan: 3"]LABOUR - Day Rate Paul (plus Labour - Day Rate Staff)[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]Footings[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD][/TD]
[TD][/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Wall[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD][/TD]
[TD][/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Cleaning[/TD]
[TD]LABOUR - Day Rate Paul[/TD]
[TD][/TD]
[TD][/TD]
[TD]4[/TD]
[/TR]
</tbody>[/TABLE]

 

[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