Stumped Again

[anwaee2]

I can do a join/transpose with one column but nothing I have tried will do a join/transpose with the condition being in two columns. Below is a sample of what I am trying to do. Thanks for any help you may give.

A B C D Fruit Number Sequence Shown Apples #3 1 1 Oranges #1 2 2 Pears #1 3 1 Lemons #2 4 2 Oranges #1 5 2 Lemons #2 6 2 Apples #1 7 3 Plums #1 8 1 Apples #1 9 3 Pears #2 10 1 Apples #1 11 3 Oranges #2 12 1 FROM ABOVE TO BELOW A B C D Fruit Number Sequence Shown Apples #1 7, 9, 11 3 Apples #3 1 1 Lemons #2 4, 6 2 Oranges #1 2, 5 2 Oranges #2 12 1 Pears #1 3 2 Pears #2 10 1 Plums #1 8 1 <colgroup><col width="65" span="4" style="width: 65pt;"></colgroup><tbody> </tbody>

<colgroup><col width="65" span="4" style="width: 65pt;"></colgroup><tbody>
</tbody>

 

[anwaee2]

Update: I have been doing a copy/paste of the original each time I run it. I looked for spelling or anything else I could think of that might be different. I saw none but I did go back and retyped "Apples" again in each "Apples" cell. Well now both macros work fine. When I went back to the original I found that the Apples in Sequence 7 had a space after it that you of course could not see. I didn't know that hitting the space bar before hitting enter could cause something like that.

Thanks to both you and Mick for all the help. Again this forum is great.

 

[MickG]

Another option, give it a try:-

[COLOR="Navy"]Sub[/COLOR] MG10Jan27
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Rw [COLOR="Navy"]As[/COLOR] Range, r [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Temp [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rw [COLOR="Navy"]In[/COLOR] Rng
Rw = Trim(Rw.Value)
[COLOR="Navy"]If[/COLOR] InStr(Rw, ",") = 0 [COLOR="Navy"]Then[/COLOR] Rw = Rw & "," & Rw.Offset(, 1).Value
r = 0
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
      Dn = Trim(Dn.Value)
       [COLOR="Navy"]If[/COLOR] InStr(Dn, ",") = 0 [COLOR="Navy"]Then[/COLOR] Dn = Dn & "," & Dn.Offset(, 1).Value
            r = r + 1
        [COLOR="Navy"]If[/COLOR] Dn = Rw [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Application.CountIf(Rng(1).Resize(r), Rw) = 1 [COLOR="Navy"]Then[/COLOR]
               [COLOR="Navy"]Set[/COLOR] Temp = Rw
            [COLOR="Navy"]Else[/COLOR]
                Temp.Offset(, 2).Value = Temp.Offset(, 2).Value & "," & Dn.Offset(, 2).Value
                [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] Rw
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng: Dn = Split(Dn.Value, ",")(0): [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
Rng.Resize(, 4).Sort key1:=[A2], order1:=xlAscending, Header:=xlYes

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[MickG]

Yet another option:- Results start "H1"

[COLOR="Navy"]Sub[/COLOR] MG10Jan41
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] r [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray() [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Dn = Trim(Dn.Value)
  [COLOR="Navy"]If[/COLOR] InStr(Dn, ",") = 0 [COLOR="Navy"]Then[/COLOR] Dn = Dn & "," & Dn.Offset(, 1).Value
    r = r + 1
    [COLOR="Navy"]If[/COLOR] Application.CountIf(Rng(1).Resize(r), Dn) = 1 [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        ReDim Preserve Ray(1 To c)
        Ray(c) = Dn.Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
c = 0
ReDim nray(1 To UBound(Ray) + 1, 1 To 4)
nray(1, 1) = "Fruit": nray(1, 2) = "Number": nray(1, 3) = "Sequence": nray(1, 4) = "Shown"

[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
      [COLOR="Navy"]If[/COLOR] Ray(n) = Dn [COLOR="Navy"]Then[/COLOR]
        nray(n + 1, 1) = Split(Dn.Value, ",")(0)
        nray(n + 1, 2) = Split(Dn.Value, ",")(1)
        nray(n + 1, 3) = nray(n + 1, 3) & IIf(nray(n + 1, 3) = "", Dn.Offset(, 2).Value, "," & Dn.Offset(, 2).Value)
        nray(n + 1, 4) = Dn.Offset(, 3).Value
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Range("H1").Resize(UBound(Ray, 1) + 1, 4)
    .Value = nray
    .Sort key1:=[H1], order1:=xlAscending, Header:=xlYes
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[anwaee2]

Thank you so much Mick. This one works great and doesn't seem to matter if there is an extra space or not. That will save me a lot of time not having to go back and check each cell. I will now apply this to a much larger data base. You guys are the best. Thanks again.

Larry

Another option, give it a try:-

[COLOR=Navy]Sub[/COLOR] MG10Jan27
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Rw [COLOR=Navy]As[/COLOR] Range, r [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Temp [COLOR=Navy]As[/COLOR] Range, nRng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Rw [COLOR=Navy]In[/COLOR] Rng
Rw = Trim(Rw.Value)
[COLOR=Navy]If[/COLOR] InStr(Rw, ",") = 0 [COLOR=Navy]Then[/COLOR] Rw = Rw & "," & Rw.Offset(, 1).Value
r = 0
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
      Dn = Trim(Dn.Value)
       [COLOR=Navy]If[/COLOR] InStr(Dn, ",") = 0 [COLOR=Navy]Then[/COLOR] Dn = Dn & "," & Dn.Offset(, 1).Value
            r = r + 1
        [COLOR=Navy]If[/COLOR] Dn = Rw [COLOR=Navy]Then[/COLOR]
            [COLOR=Navy]If[/COLOR] Application.CountIf(Rng(1).Resize(r), Rw) = 1 [COLOR=Navy]Then[/COLOR]
               [COLOR=Navy]Set[/COLOR] Temp = Rw
            [COLOR=Navy]Else[/COLOR]
                Temp.Offset(, 2).Value = Temp.Offset(, 2).Value & "," & Dn.Offset(, 2).Value
                [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = Dn Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]Next[/COLOR] Rw
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng: Dn = Split(Dn.Value, ",")(0): [COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
Rng.Resize(, 4).Sort key1:=[A2], order1:=xlAscending, Header:=xlYes

[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[MickG]

You're welcome