Splitting & Listing Unique values from cells

[Guest]

Hi, I have an array of data as per below in 'OldWorksheet':

Supply Category Supplier
Product 1 Supplier 1;Supplier 3
Product 2 Supplier 2
Product 3 Supplier 1;Supplier 3;Supplier 6
Product 2 Supplier 5
Product 2 Supplier 4;Supplier 5
Product 2 Supplier 1;Supplier 2;Supplier 3
Product 4 Supplier 2
Product 4 Supplier 2;Supplier 1
Product 4 Supplier 5;Supplier 1
Product 5 Supplier 3
Product 5 Supplier 4;Supplier 5
Product 6 Supplier 4
Product 1 Supplier 3

What I need to do is create a list of Unique Suppliers (Column A,
'Newworksheet'), with the products they supply (In Column B, 'Newworksheet')
- if multiple products, they can either be all in the same cell and
separated, or in subsequent columns (C, D, E etc.)

Logically I imagine it involves:
1. Using text-to-columns to initially split the supplier names out into
seperate cells
2. Identifying the unique records in the array
3. Copying this list to 'NewWorksheet'!Column A
4. Sequentially looking up each product by supplier from 'OldWorksheet' and
placing them in 'NewWorksheet'!Column B, C, D etc.

Any hints, I imagine it needs some logic applied as well as Excel & VBA.

Thanks

 

[Guest]

See if this works. the program assume Newworksheet exists. If not make a
blank Newworksheet.

subroutine GetSuppliers reads Oldworksheet
Subroutine AddSupplier adds supplier and product if they don't exist.


Sub GetSuppliers()

Const OldWs = "OldWorksheet"
Dim Product As String
Dim Supplier As String

LastRowOldWs = Sheets(OldWs).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(OldWs).Activate
Set OldWsRange = Sheets(OldWs). _
Range(Cells(2, 1), Cells(LastRowOldWs, 1))

For Each OldWsCell In OldWsRange

'Get Product and supplier
Product = OldWsCell.Value
SupplierCell = OldWsCell.Offset(rowoffset:=0, columnoffset:=1)
'strip off any leading blanks
For i = 1 To Len(SupplierCell)
If StrComp(Mid(SupplierCell, i, 1), " ") <> 0 Then Exit For
Next i
SupplierCell = Mid(SupplierCell, i)

'get each supplier
Do While Len(SupplierCell) <> 0

If InStr(SupplierCell, ";") Then

Supplier = Left(SupplierCell, InStr(SupplierCell, ";") - 1)
SupplierCell = Mid(SupplierCell, _
InStr(SupplierCell, ";") + 1)
Else
Supplier = SupplierCell
SupplierCell = ""
End If

Call AddSupplier(Product, Supplier)
Loop

Next OldWsCell


End Sub

Sub AddSupplier(Product As String, Supplier As String)

Const NewWs = "NewWorksheet"

LastRowNewWs = Sheets(NewWs).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(NewWs).Activate
Set NewWsRange = Sheets(NewWs). _
Range(Cells(1, 1), Cells(LastRowNewWs, 1))

FoundProduct = False
For Each NewWsCell In NewWsRange

If StrComp(NewWsCell, Product) = 0 Then

FoundProduct = True
'found product now check supplier
LastColNewWs = Sheets(NewWs). _
Cells(NewWsCell.Row, Columns.Count).End(xlToLeft).Column
Set SupplietRange = Sheets(NewWs). _
Range(Cells(NewWsCell.Row, 2), _
Cells(NewWsCell.Row, LastColNewWs))

FoundSupplier = False
For Each SupplierCell In SupplietRange

If StrComp(Supplier, SupplierCell) = 0 Then

FoundSupplier = True
Exit For
End If


Next SupplierCell

'this is new supplier so add supplier
If FoundSupplier = False Then

Sheets(NewWs).Cells(NewWsCell.Row, LastColNewWs + 1) = _
Supplier
End If

Exit For
End If
Next NewWsCell

If FoundProduct = False Then
If IsEmpty(Cells(1, 1)) Then
Productrow = 1
Else
Productrow = LastRowNewWs + 1
End If

Sheets(NewWs).Cells(Productrow, 1) = Product
Sheets(NewWs).Cells(Productrow, 2) = Supplier

End If
End Sub

 

[Guest]

Thanks Joel - you've given me heaps of clues, but it wasn't quite on the
money -

Effectively, once it has done what you gave me, it also needs to be able to
combine duplicate suppliers and products. This is where the problem lies, and
increasingly I think that this is simply not possible!

Therefore, using the original example, the finish in NewWorksheet should
look something like;

Supply Category Supplier
Supplier 1 Product 1; Product 3; Product 2; Product 4
Supplier 2 Product 2; Product 4
Supplier 3 Product 1; Product 3; Product 2; Product 5
Supplier 4 Product 2; Product 5; Product 6
Supplier 5 Product 2; Product 4; Product 5
Supplier 6 Product 3

I think the trick is more in how to filter unique entries from an array
(Suppliers), copy and paste that list into the new worksheet, then
systematically lookup that value in the array of products and paste them in
the columns across from the Supplier.

But welcome to any suggestions, and your code is certainly an improvement
from what I had...

the usual trick of recording the acion and cleaning up the code doesn't
work, since the array can be any size...

 

[Guest]

I ran your data and below are the results I got. I believe it is doing the
filtering you have asked for.


Product 1 Supplier 1 Supplier 3
Product 2 Supplier 2 Supplier 5 Supplier 4 Supplier 1 Supplier 3
Product 3 Supplier 1 Supplier 3 Supplier 6
Product 4 Supplier 2 Supplier 1 Supplier 5
Product 5 Supplier 3 Supplier 4 Supplier 5
Product 6 Supplier 4

 

[Guest]

Tis morning when I was working on the program I found spaces in the data you
posted a manually removed these spaces. I realized I could improve the
program. there are 3 reasons the products and suppliers weren't combining

I always try to get a program to run under ANY condition. Error checking is
always an important part of a program.

1) Extra Spaces - I emoved the spaces and bgining and End of Products and
Suppliers.
2) The case (Upper Case or Lower Case) weren't the same between entries. I
converted all Products and Suppliers so 1st letter of every word is capital
and rest of words are lower case.
3) Spelling Errors in Products and suppliers. I can't fix spelling. If
items don't combine, carefully check the Spelling for typos in data. I often
don't find the typo errors until I run a program on teh data. Often I have
to fix the typos and re-run the program.

I'm filtering the data with the strcomp() function. Only adding items that
aren't previously in the newworksheet.

Sub GetSuppliers()

Const OldWs = "OldWorksheet"
Dim Product As String
Dim Supplier As String

LastRowOldWs = Sheets(OldWs).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(OldWs).Activate
Set OldWsRange = Sheets(OldWs). _
Range(Cells(2, 1), Cells(LastRowOldWs, 1))

For Each OldWsCell In OldWsRange

'Get Product and supplier
Product = OldWsCell.Value
'strip off leading and trailing blanks
For i = 1 To Len(Product)
If StrComp(Mid(Product, i, 1), " ") <> 0 Then Exit For
Next i
Product = Mid(Product, i)

For i = Len(Product) To 1 Step -1
If StrComp(Mid(Product, i, 1), " ") <> 0 Then Exit For
Next i
Product = Left(Product, i)

SupplierCell = OldWsCell.Offset(rowoffset:=0, columnoffset:=1)

'get each supplier
Do While Len(SupplierCell) <> 0

If InStr(SupplierCell, ";") Then

Supplier = Left(SupplierCell, InStr(SupplierCell, ";") - 1)
SupplierCell = Mid(SupplierCell, _
InStr(SupplierCell, ";") + 1)
Else
Supplier = SupplierCell
SupplierCell = ""
End If

'strip off leading and trailing blanks
For i = 1 To Len(Supplier)
If StrComp(Mid(Supplier, i, 1), " ") <> 0 Then Exit For
Next i
Supplier = Mid(Supplier, i)

For i = Len(Supplier) To 1 Step -1
If StrComp(Mid(Supplier, i, 1), " ") <> 0 Then Exit For
Next i
Supplier = Left(Supplier, i)

'Convert String to first letter Capital
Product = StrConv(Product, vbLowerCase)
Product = StrConv(Product, vbProperCase)

Supplier = StrConv(Supplier, vbLowerCase)
Supplier = StrConv(Supplier, vbProperCase)

Call AddSupplier(Product, Supplier)
Loop

Next OldWsCell


End Sub

Sub AddSupplier(Product As String, Supplier As String)

Const NewWs = "NewWorksheet"

LastRowNewWs = Sheets(NewWs).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(NewWs).Activate
Set NewWsRange = Sheets(NewWs). _
Range(Cells(1, 1), Cells(LastRowNewWs, 1))

FoundProduct = False
For Each NewWsCell In NewWsRange

If StrComp(NewWsCell, Product) = 0 Then

FoundProduct = True
'found product now check supplier
LastColNewWs = Sheets(NewWs). _
Cells(NewWsCell.Row, Columns.Count).End(xlToLeft).Column
Set SupplietRange = Sheets(NewWs). _
Range(Cells(NewWsCell.Row, 2), _
Cells(NewWsCell.Row, LastColNewWs))

FoundSupplier = False
For Each SupplierCell In SupplietRange

If StrComp(Supplier, SupplierCell) = 0 Then

FoundSupplier = True
Exit For
End If


Next SupplierCell

'this is new supplier so add supplier
If FoundSupplier = False Then

Sheets(NewWs).Cells(NewWsCell.Row, LastColNewWs + 1) = _
Supplier
End If

Exit For
End If
Next NewWsCell

If FoundProduct = False Then
If IsEmpty(Cells(1, 1)) Then
Productrow = 1
Else
Productrow = LastRowNewWs + 1
End If

Sheets(NewWs).Cells(Productrow, 1) = Product
Sheets(NewWs).Cells(Productrow, 2) = Supplier

End If
End Sub

 

[Guest]

Hi Joel

Will try your revised code, and see how it goes.

Just one other 'twist', what if the Products are in Column C and Suppliers
in Column V? I worked out the how to move the reverence for the suppliers by
changing columnoffset:=1 to columnoffset:=20, but how do I get it to read
Column C as the first ?

FYI, the spelling is not a great concern - the suppliers are all Chinese, so
spelling is not a priority!

Appreciate your assistance, this is the final hurdle before it is finished!

Thanks

 

[Guest]

For suppliers I like this form of the equation better. I thought it was
clearer when it was the adjacent colunm to use an offset. When you are going
all the way out to column V I think its clear to just use the
cells(row,column) format. Not sure why you got an offset of 20. The
offset was from the range where the Product column. If you were going from
column A to column V it would be 21. If you were going from column C to V it
would be 19. It was originally Column A and now column C. You chose an
Offset from column B (the old supplier column) which is wrong according to
the way the code is designed. Using the cells(row,column) format of the
equation would prevent this type error.

from:
SupplierCell = OldWsCell.Offset(rowoffset:=0, columnoffset:=21)
to:
SupplierCell = Sheets(OldWs).cells(OldWsCell.row,22)


for Products change
from:
Set OldWsRange = Sheets(OldWs). _
Range(Cells(2, 1), Cells(LastRowOldWs, 1))

to:
Set OldWsRange = Sheets(OldWs). _
Range(Cells(2, 3), Cells(LastRowOldWs, 3))