Returning values to unique rows

[D Zandveld]

I have an array of data that contains Suppliers, Projects, Priority, Contact,
Country (plus a buch of others that don't matter). Lets call this 'Data'

What I need to do is run a report that identifies each name in the Supplier
column and return the value to a new worksheet 'Report'

So, to put a picture on it, the data could be:

A B C
D E
1 Supplier Project Priority Contact
Country
2 S1, S2 Apple 01 High John
Australia
3 S3, S1 Orange 01 High Steve
Canada
4 S1, S2, S3 Peach 02 Medium John
Australia
5 S2 Mango 03 Low Max
England

What I need to be able to do is extrapolate this data to the 'Report'
worksheet based on the values in Supplier. So, the result in 'Report' based
on the above would be:

A B C
D E
1 Supplier Project Priority Contact
Country
2 S1 Apple 01 High John
Australia
3 S1 Orange 01 High Steve
Canada
4 S1 Peach 02 Medium John
Australia
5 S2 Apple 01 High John
Australia
6 S2 Peach 02 Medium John
Australia
7 S2 Mango 03 Low Max
England
8 S3 Orange 01 High Steve
Canada
9 S3 Peach 02 Medium John
Australia

Does anyone have an idea as to how or if this can be done?

 

[D Zandveld]

Also, I have installed Ron deBruin's Easy Filter, which using the 'Contains'
function achieves the required result. The only problem is that I just need
the code to perform this function, not the rest of the functions (which are
great but unnecessry in this instance). Access to the code for this appears
blocked and requires a password.

Thanks

 

[D Zandveld]

Sorry, it IS locked due to protection of intellectual property. All good.

Any way to replicate this function directly in VBA?

 

[kemal]

This code is to be put under "datasheetdetailed" which will be your
report sheet.So whenever you select
this sheet your report will be ready.
"supplier" is the sheet you store supplier names starting from "a2".
like s1,s2,s3 etc
"datasheet" contains your raw data

Please create above sheets to test the code or just change sheet names
mentioned below code.

Private Sub Worksheet_Activate()

Dim rng1 As Range
Dim i1 As Range
Dim rng2 As Range
Dim i2 As Range
Dim rnum As Double
Dim found As Double
rnum = 2

With Worksheets("supplier")
Set rng1 = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With

With Worksheets("datasheet")
Set rng2 = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With

Worksheets("datasheetdetailed").Range("a2:iv10000").ClearContents

For Each i1 In rng1
For Each i2 In rng2
found = InStr(1, i2.Value, i1.Value)
If found <> 0 Then
With Worksheets("datasheetdetailed")
.Cells(rnum, 1) = i1
.Cells(rnum, 2) = i2.Offset(, 1) ' Modify below bits
according to your data
.Cells(rnum, 3) = i2.Offset(, 2)
.Cells(rnum, 4) = i2.Offset(, 3)
.Cells(rnum, 5) = i2.Offset(, 4)
.Cells(rnum, 6) = i2.Offset(, 5)
End With
rnum = rnum + 1
End If
Next i2
Next i1
End Sub