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>

 

[MickG]

Try this:-
NB:- This code will alter your data

[COLOR="Navy"]Sub[/COLOR] MG08Jan15
[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] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), 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
Txt = Dn.Value & Dn.Offset(, 1).Value
    [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        .Add Txt, Dn.Offset(, 2)
    [COLOR="Navy"]Else[/COLOR]
        [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)
      .Item(Txt).Value = .Item(Txt).Value & ", " & Dn.Offset(, 2).Value
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] With
Rng.Resize(, 4).Sort key1:=[A1], order1:=xlAscending, Header:=xlYes

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

Regards Mick

 

[anwaee2]

I am not sure why but I get the message "ActiveX component can't create Object. The line now highlighted in the macro is "With CreateObject ("scripting dictionary")".
Thank you.

 

[anwaee2]

I just found out that since I am on Excel for Mac, that I don't have access to ActiveX. Is there maybe another way around this? Thanks again.

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG08Jan10
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] temp [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
Rng.Resize(, 4).Sort key1:=[A1], order1:=xlAscending, Header:=xlNo
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Dn = Dn.Value & "," & Dn.Offset(, 1)
    [COLOR="Navy"]If[/COLOR] temp [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] temp = Dn
    [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not temp = Dn [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] temp = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]If[/COLOR] temp = Dn [COLOR="Navy"]Then[/COLOR]
                    temp.Offset(, 2).Value = temp.Offset(, 2).Value & "," & Dn.Offset(, 2).Value
                [COLOR="Navy"]End[/COLOR] If
                [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]
[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
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[anwaee2]

Thanks again Mick. The macro works but doesn't do exactly what I need it to do. The group on the left is what your macro returned for me. Either one of the two on the left is what I really need. I have a much bigger data base that I need to reduce. Thanks again to you and all the members on this forum. It has been a big help to me in the past and is really appreciated.

<tbody>
</tbody>

Fruit	Number	Sequence	Shown		Fruit	Number	Sequence	Shown		Fruit	Number	Sequence	Shown
Apples	#3	1	1		Apples	#1	7, 9, 11	3		Apples	#1	7, 9, 11	3
Apples	#1	9,11	3		Lemons	#2	4, 6	2		Apples	#3	1	1
Apples	#1	7	3		Oranges	#1	2, 5	2		Lemons	#2	4, 6	2
Lemons	#2	4,6	2		Pears	#1	3	2		Oranges	#1	2, 5	2
Oranges	#1	2	2		Apples	#3	1	1		Oranges	#2	12	1
Oranges	#1	5	2		Oranges	#2	12	1		Pears	#1	3	2
Oranges	#2	12	1		Pears	#2	10	1		Pears	#2	10	1
Pears	#1	3	1		Plums	#1	8	1		Plums	#1	8	1
Pears	#2	10	1
Plums	#1	8	1

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

Thank you all so much
Larry

 

[MickG]

Running my last code on your initial data returned the below to me !!!!
Was your data different ????

Fruit	Number	Sequence	Shown
Apples	#3	1	1
Apples	#1	7,9,11	3
Lemons	#2	4,6	2
Oranges	#1	2,5	2
Oranges	#2	12	1
Pears	#1	3	1
Pears	#2	10	1
Plums	#1	8	1

<colgroup><col width="108" style="width: 81pt; mso-width-source: userset; mso-width-alt: 3840;"> <col width="64" style="width: 48pt;" span="3"> <tbody> </tbody>

 

[anwaee2]

Sorry Mick, I thought I posted this sooner but just saw my reply did not post. My data was the same as I posted before. Below is my data and on the left is your macro result. Everything seems to work except for the "Apples #1 " which didn't group together. Thanks again to you and all of the ones on the forum for all the help you have given me in the past. Again below is my list and on the right is the result of your macro.

Fruit	Number	Sequence	Shown		Fruit	Number	Sequence	Shown
Apples	#3	1	1		Apples	#3	1	1
Oranges	#1	2	1		Apples	#1	9,11	3
Pears	#1	3	1		Apples	#1	7	3
Lemons	#2	4	2		Lemons	#2	4,6	2
Lemons	#2	6	2		Oranges	#1	2	1
Apples	#1	7	3		Oranges	#2	12	1
Plums	#1	8	1		Pears	#1	3	1
Apples	#1	9	3		Pears	#2	10	1
Pears	#2	10	1		Plums	#1	8	1
Apples	#1	11	3
Oranges	#2	12	1

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

 

[Rick Rothstein]

Just out of curiosity, does this macro work for you (I don't have a Mac, so I cannot test it)...

[table="width: 500"]
[tr]
	[td]Sub SequenceNumbersPerFruitNumber()
  Dim R As Long, LastRow As Long, Arr As Variant
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  ReDim Arr(2 To LastRow, 1 To 1)
  For R = 2 To LastRow
    Arr(R, 1) = Application.Trim(Join(Application.Transpose(Evaluate(Replace("IF((A" & R & "=A2:A#)*(B" & R & "=B2:B#),C2:C#,"""")", "#", LastRow)))))
  Next
  Range("C2:C" & LastRow) = Arr
  Columns("A:D").RemoveDuplicates Array(1, 2, 3, 4), xlYes
  Columns("A:D").Sort [A1], xlAscending, Header:=xlYes
End Sub[/td]
[/tr]
[/table]

 

[anwaee2]

Sorry, I wish I could say yes but I get the exact same results as Mick's macro except this macro runs for a really long time before it gives the results. I ran it twice to make sure. Thank you for trying, i really appreciate it.