Using Vba to acquire lookup results in one cell

[Sazzle14]

Hi I used the formula below in trying to solve a puzzle I have, and it has got really close to what I need. It presented the results in col 1 and 2 below (C and D in your formula). However, What I need is to get the results separately i.e. Results for "7" in one cell in the spreadsheet and Results for "8" in another and the same with 9. So I need the formula to specify what it is looking for in column "BoX" but deliver the results in the same way it did for Column 1 and 2. I.e. it brings back multiple values with either a "," to separate or if possible a soft return {alt & Enter}
I know I am asking a lot but would so appreciate your help, I have tried Index and other VBA solutions and not having much luck.

Box	Name	Column1	Column2
7	Corel	7	Corel , Steph , Jen , Amanda
7	Steph	8	Carol, Amer, Vicky, Charlotte, David
7	Jen	9	Kam, Gwen , Raj, David, Mark , Emma
7	Amanda
8	Carol
8	Amer
8	Vicky
8	Charlotte
8	David
9	Kam
9	Gwen
9	Raj
9	David
9	Mark
9	Emma

<tbody>
</tbody>

Originally Posted by Tinbendr
Welcome to the board!

Code:

Sub MergeGroups()
 Dim WS As Worksheet
 Dim Rng As Range
 Dim LastRow As Long
 Dim Ctr As Long
 Dim Temp$
     'Result Row
     Ctr = 1

     Set WS = ActiveWorkbook.ActiveSheet
     With WS
         'Last row of column A with data.
         LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

         'Loop through each item in Col A.
         For Each Rng In Range("A2:A" & LastRow)
             'Compare to next item down.  If equal build user string.
             If Rng.Offset(1, 0).Value = Rng.Value Then
                 Temp$ = Temp$ & Rng.Offset(0, 1).Value & ", "
             Else
                 'Servers no longer match.
                 Ctr = Ctr + 1
                 'Add last match
                 Temp$ = Temp$ & Rng.Offset(0, 1).Value
                 'Post to Col C & D.
                 .Range("C" & Ctr).Value = Rng.Value
                 .Range("D" & Ctr).Value = Temp$
                 'Clear Temp$
                 Temp$ = ""
             End If
         Next
     End With
 End Sub

 

[Sazzle14]

Just typed it in - although now I feel you are probably shaking your head in disbelief - eek!

With CreateObject("scripting.dictionary")
      For Each Cl In Range("F2", Range("F" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & Chr(10) & Cl.Offset(, 1).Value
         End If
      Next Cl
      Worksheet("Sheet1").Range("j5").Value = .Item(1)
      Worksheet("Sheet1").Range("K5").Value = .Item(2)
      Worksheet("Sheet1").Range("l5").Value = .Item(3)
      Worksheet("Sheet1").Range("j6").Value = .Item(4)
      Worksheet("Sheet1").Range("k6").Value = .Item(5)
      Worksheet("Sheet1").Range("l6").Value = .Item(6)
      Worksheet("Sheet1").Range("j7").Value = .Item(7)
      Worksheet("Sheet1").Range("k7").Value = .Item(8)
      Worksheet("Sheet1").Range("l7").Value = .Item(9)
   End With
End Sub

 

[Fluff]

You've missed the s from the end of worksheets

 

[Sazzle14]

Oh my goodness yes I have!!! Yes it is perfect!! thank you so so so much and thank you for being so patient!!

 

[Fluff]

You're welcome