Combine Unique and Duplicate Data Multiple Criteria

[Rugar10]

Hello,

This has been puzzling me for some time. I operate a weekly farm share and we attach custom labels to each customer share. The customer places an order with multiple items and we can export a CSV file. The attached sample data highlights each row as a separate customer with the full items ordered separated by commas in the third column. This can be fed into our DYMO label printer. Each row is one label. Here is the problem. Some items need to be packaged in different packages and stored in a different location. For example: Floral Fun needs it's own customer row with the only item being "Floral Fun" so one label is printed for that customer for a bouquet of flowers. Another example, meats are frozen so those need their own label as well. All other items that can be packed together in the cooler such as a Veggie Share and Eggs and Tofu can stay together but they need to be carriage returned in the cell so the label prints each combined item on a new label line. I have been using find/replace in the items column to replace all commas in the items column with a carriage return. Then I go through each customer and make new rows with items that need their own label like the flowers or meat. I want to identify a list of unique items and categorize which items are ok to be combined in the same package. I want new rows to be created for customers with the items that can be combined. The sample data shows how i receive it and how I want it to look. I would like some automation. Either by formulas that I can input a new weekly CSV file into a pre-formatted spreadsheet or dashboard. Or I want some sort of macro or function or even pivot table to help me make this task more efficient. Thank you in advance for you suggestions and help.

Sample Data (sorry i don't know how to attach the excel sheet, open to learning)

First Name	Last Name	Items
Nicholas	Baldwin	1 Veggie Share
Melissa	Belliveau	1 Veggie Share
Debra	Brady	1 Veggie Share
Jennifer	Bryan	1 Veggie Share
Madaline	Champagne	1 Veggie Share, 1 Greens Galore
Sarah	Crosman	1 Veggie Share, 1 Eggs (hen)
Olga	Cushman	1 Veggie Share, 2 Eggs (hen), 2 Milk, Jersey Raw, 1x1 bunch Beets, Rainbow - bunch, 1x1 head Celery, 1x1 quart Potatoes, new - red, 1x1 bunch Carrots, orange bunched, 1x12 Pint SNAP Blueberries, wild low bush - organic
Paula	Deering	1 Veggie Share, 2 Yogurt, 3x1 Pint Yogurt, maple, 15oz *ORDER BY SAT. PM*
Laura	Gross-Balzano	1 Veggie Share, 1 Basic Meat Share
Tammy	Jewell	1 Greens Galore, 1 Floral Fun

<tbody>
</tbody>

My Goal

First Name	Last Name	Items
Nicholas	Baldwin	1 Veggie Share
Melissa	Belliveau	1 Veggie Share
Debra	Brady	1 Veggie Share
Jennifer	Bryan	1 Veggie Share
Madaline	Champagne	1 Veggie Share
Madaline	Champagne	1 Greens Galore
Sarah	Crosman	1 Veggie Share 1 Eggs (hen)
Olga	Cushman	1 Veggie Share 2 Eggs (hen) 2 Milk, Jersey Raw 1x1 bunch Beets, Rainbow - bunch 1x1 head Celery 1x1 quart Potatoes, new - red 1x1 bunch Carrots, orange bunched
Olga	Cushman	1x12 Pint SNAP Blueberries, wild low bush - organic
Paula	Deering	1 Veggie Share 2 Yogurt 3x1 Pint Yogurt, maple, 15oz *ORDER BY SAT. PM*
Laura	Gross-Balzano	1 Veggie Share
Laura	Gross-Balzano	1 Basic Meat Share
Tammy	Jewell	1 Greens Galore
Tammy	Jewell	1 Floral Fun

<tbody>
</tbody>

 

[MickG]

Try this for results on sheet2
NB:- Add "Seperated" produce where shown on code.

[COLOR="Navy"]Sub[/COLOR] MG12Sep00
[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] Sp [COLOR="Navy"]As[/COLOR] Variant, oLine [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] xLine [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, nDic [COLOR="Navy"]As[/COLOR] Object, Nam [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Fd [COLOR="Navy"]As[/COLOR] Boolean, nNam [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]Set[/COLOR] nDic = CreateObject("scripting.dictionary")
nDic.CompareMode = vbTextCompare
With Dic  '[COLOR="Green"][B]Nb add Produce to be seperate, as below[/B][/COLOR]
.Add "Floral Fun", ""
.Add "Basic Meat Share", ""
.Add "Greens Galore", ""
 [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
  Sp = Split(Dn.Offset(, 2), ",")
    oLine = "": xLine = ""
    [COLOR="Navy"]If[/COLOR] Not nDic.exists(Dn.Value & "," & Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Nam [COLOR="Navy"]In[/COLOR] Sp
           Fd = False
           [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
            [COLOR="Navy"]If[/COLOR] InStr(Nam, K) > 0 [COLOR="Navy"]Then[/COLOR]
                Fd = True
                nNam = Nam
                [COLOR="Navy"]Exit[/COLOR] For
            [COLOR="Navy"]End[/COLOR] If
           [COLOR="Navy"]Next[/COLOR] K
             [COLOR="Navy"]If[/COLOR] Fd [COLOR="Navy"]Then[/COLOR]
               xLine = xLine & IIf(xLine = "", Trim(nNam), "," & vbLf & Nam)
            [COLOR="Navy"]Else[/COLOR]
                oLine = oLine & IIf(oLine = "", Trim(Nam), "," & vbLf & Nam)
           [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Nam
        nDic.Add Dn.Value & "," & Dn.Offset(, 1).Value, Array(oLine, xLine)
    [COLOR="Navy"]Else[/COLOR]
        Q = nDic(Dn.Value & "," & Dn.Offset(, 1).Value)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Nam [COLOR="Navy"]In[/COLOR] Sp
                Fd = False
                [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
                    [COLOR="Navy"]If[/COLOR] InStr(Nam, K) > 0 [COLOR="Navy"]Then[/COLOR]
                        Fd = True
                    nNam = Nam
                    [COLOR="Navy"]Exit[/COLOR] For
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR] K
             [COLOR="Navy"]If[/COLOR] Fd [COLOR="Navy"]Then[/COLOR]
                Q(1) = Q(1) & "," & vbLf & Trim(nNam)
            [COLOR="Navy"]Else[/COLOR]
                Q(0) = Q(0) & "," & vbLf & Trim(Nam)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Nam
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
 [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] nDic.keys
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] nDic(K)
            [COLOR="Navy"]If[/COLOR] p <> "" [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] nDic(K)(UBound(nDic(K))) = p [COLOR="Navy"]Then[/COLOR]
                    Sp = Split(p, ",")
                    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Nam [COLOR="Navy"]In[/COLOR] Sp
                        c = c + 1
                        .Cells(c, 1) = Split(K, ",")(0)
                        .Cells(c, 2) = Split(K, ",")(1)
                        .Cells(c, 3) = Nam
                    [COLOR="Navy"]Next[/COLOR] Nam
                [COLOR="Navy"]Else[/COLOR]
                    c = c + 1
                    .Cells(c, 1) = Split(K, ",")(0)
                    .Cells(c, 2) = Split(K, ",")(1)
                    .Cells(c, 3) = p
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] p
 [COLOR="Navy"]Next[/COLOR] K
 .Rows.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Rugar10]

Thank you for your reply Mick.

My Excel skill level is more novice compared to the experience I have seen on this site. Could you explain a little more about how I enter this code and execute it? Or could you refer me to a good tutorial explaining what to do with your code? I am more familiar with cell level functions and less familiar with using VBA code.

Thank you,

Justin

 

[MickG]

Try this:-
To Save and Run Code:-
Copy code from Thread
In Your Data sheet , Click "Alt+F11",:- Vb Window appears.
From the VBWindow toolbar, Click "Insert" ,"Module":- New VBwindow appears .
Paste Code into this window.
Close Vbwindow.
On sheet Click "Developer tab", Click "Macro". Macro dialog box appears.
Select Macro (with same name) from List.
On the right of Dialog box Click "Run"
Sheet2 should now be updated.
Regrds Mick

 

[Rugar10]

This is great Mick!

I was able to get it to work. This is a significant step forward. It did flag two additional questions for me when i saw the results.

1. There is more info in columns to the right of the sample data that you saw. I should have mentioned this. I didn't show it in the sample data because it's personal data like address and phone numbers. This information needs to stay with every row and correspond to the same names even if duplicate name is created for a new row and label item. Can this be done?

2. I am starting to understand the code. I was able to add in other items to be separated out. Sometimes 2 or more items need to be seperated from the order into a seperate combined label. For example if a customer ordered a Veggie Share, Meat, and Tempeh I would need to extract the meat and tempeh into the same row and same label. Can this be done?

Thank you for you help.

Justin

 

[MickG]

This is better ,but I can see it will need some fine tuning !!!!
Nb:- More specific foods added via "Select Case " and 2 extra columns for "Address & phone"

[COLOR="Navy"]Sub[/COLOR] MG14Sep29
'[COLOR="Green"][B]Version 2[/B][/COLOR]
[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] Sp [COLOR="Navy"]As[/COLOR] Variant, oLine [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] xLine [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, nDic [COLOR="Navy"]As[/COLOR] Object, Nam [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant, K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Fd [COLOR="Navy"]As[/COLOR] Boolean, nNam [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] nDic = CreateObject("scripting.dictionary")
nDic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
  Sp = Split(Dn.Offset(, 2), ",")
    oLine = "": xLine = ""
    ReDim ray(1 To 5)
    [COLOR="Navy"]If[/COLOR] Not nDic.exists(Dn.Value & "," & Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
       '[COLOR="Green"][B]Below is a "Select case" to send Specific Foods to particular line in array "ray"[/B][/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Nam [COLOR="Navy"]In[/COLOR] Sp
          [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] True
                [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Floral Fun") > 0: ray(1) = ray(1) & IIf(ray(1) = "", Nam, "," & vbLf & Nam)
                [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Basic Meat Share") > 0: ray(2) = ray(2) & IIf(ray(1) = "", Nam, "," & vbLf & Nam)
                [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Greens Galore") > 0: ray(3) = ray(3) & IIf(ray(1) = "", Nam, "," & vbLf & Nam)
                [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Meat") > 0: ray(4) = ray(4) & IIf(ray(1) = "", Nam, "," & vbLf & Nam)
                [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Tempeh") > 0: ray(4) = ray(4) & IIf(ray(1) = "", Nam, "," & vbLf & Nam)
                [COLOR="Navy"]Case[/COLOR] Else: ray(5) = ray(5) & IIf(ray(1) = "", Nam, "," & vbLf & Nam)
           [COLOR="Navy"]End[/COLOR] Select
        [COLOR="Navy"]Next[/COLOR] Nam
        nDic.Add Dn.Value & "," & Dn.Offset(, 1).Value, Array(ray, Dn)
    [COLOR="Navy"]Else[/COLOR]
        Q = nDic(Dn.Value & "," & Dn.Offset(, 1).Value)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Nam [COLOR="Navy"]In[/COLOR] Sp
                [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] True
                    [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Floral Fun") > 0: Q(0)(1) = Q(0)(1) & "," & vbLf & Nam
                    [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Basic Meat Share") > 0: Q(0)(2) = Q(0)(2) & "," & vbLf & Nam
                    [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Greens Galore") > 0: Q(0)(3) = Q(0)(3) & "," & vbLf & Nam
                    [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Meat") > 0: Q(0)(4) = Q(0)(4) & "," & vbLf & Nam
                    [COLOR="Navy"]Case[/COLOR] InStr(Trim(Nam), "Tempeh") > 0: Q(0)(4) = Q(0)(4) & "," & vbLf & Nam
                    [COLOR="Navy"]Case[/COLOR] Else: ray(5) = Q(0)(5) = Q(0)(5) & "," & vbLf & Nam
                [COLOR="Navy"]End[/COLOR] Select
            [COLOR="Navy"]Next[/COLOR] Nam
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
 [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] nDic.keys
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] nDic(K)(0)
            [COLOR="Navy"]If[/COLOR] p <> "" [COLOR="Navy"]Then[/COLOR]
                c = c + 1
                    .Cells(c, 1) = Split(K, ",")(0)
                    .Cells(c, 2) = Split(K, ",")(1)
                    .Cells(c, 3) = p
                   '[COLOR="Green"][B]####:- The following lines display 2 extra columns from your Data !!![/B][/COLOR]
                    .Cells(c, 4) = nDic(K)(1).Offset(, 3)
                   '[COLOR="Green"][B]####[/B][/COLOR]
                    .Cells(c, 5) = nDic(K)(1).Offset(, 4)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] p
 [COLOR="Navy"]Next[/COLOR] K
 .Rows.AutoFit
[COLOR="Navy"]End[/COLOR] With
MsgBox "Run"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Rugar10]

Thank you again Mick,

I ran the code. I saw some of the changes you made. I really just don't understand VBA however. It's looking like there is many more functions to add in because it's still not quite doing what I need. If you want to keep helping me with the problem I would be grateful. I could share the entire spreadsheet if you tell me how. I certainly don't want to take advantage of your time and hard work though. This is more complicated then i thought. At least for me that is, I"m sure you can write up code pretty quick when you know the language.

Regards, Justin