Macro to look-up and concatenate

[CHARRIS1]

Hi,

Looking for a macro that can combine some data into a single row.
Example of the table of data I have:

	A	B	C
1	APPLES	GREEN	CUT
2	ORANGES	PEELED	NOT CUT
3	PEACH	SEED	CUT
4	APPLES	RED	CUT
5	APPLES	PINK	NOT CUT
6	ORANGES	UNPEELED	CUT

<tbody>
</tbody>

Example of the output I am after (on a new sheet).

A B 1 APPLES (3) being the count of apples GREEN (CUT) RED (CUT) PINK (NOT CUT) 2 ORANGES (2) PEELED (NOT CUT) UNPEELED (CUT) 3 PEACH (1) SEED (CUT) <tbody> </tbody>

<tbody>
</tbody>

Other fruit may be added from time to time, so ideally I would like the macro to be able to lookup the values in column A and start a new row.
I would also need to refresh the data every fortnight - so thinking a button formula - rather a constantly running macro.

Thanks for the help. Let me know if anything isn't clear.

 

[Osvaldo Palmeiro]

Hi.
I assumed the table is on Sheet1 so the result will be on Sheet2.

Sub LookUpConcat()
 Dim wsO As Worksheet, wsD As Worksheet, LR As Long, k As Long, c As Range, frstAddress As String
  Set wsO = Sheets("Sheet1"): Set wsD = Sheets("Sheet2")
     For k = 1 To wsO.Cells(Rows.Count, 1).End(3).Row
      If Application.CountIf(wsO.Range("A1:A" & k), wsO.Cells(k, 1)) > 1 Then GoTo nextfruit
      Set c = wsO.Range("A1:A" & wsO.Cells(Rows.Count, 1).End(3).Row).Find(wsO.Cells(k, 1), Lookat:=xlWhole)
       If Not c Is Nothing Then
         frstAddress = c.Address
          LR = wsD.Cells(Rows.Count, 1).End(3).Row
          wsD.Cells(LR + 1, 1) = c.Value
           Do
            If wsD.Cells(LR + 1, 2) = "" Then
              wsD.Cells(LR + 1, 2) = c.Offset(, 1).Value & "(" & c.Offset(, 2).Value & ")"
            Else
             wsD.Cells(LR + 1, 2) = wsD.Cells(LR + 1, 2) & Chr(10) & _
              c.Offset(, 1).Value & "(" & c.Offset(, 2).Value & ")"
            End If
            Set c = wsO.Range("A1:A" & wsO.Cells(Rows.Count, 1).End(3).Row).FindNext(c)
           Loop While Not c Is Nothing And c.Address <> frstAddress
       End If
nextfruit:
     Next k
End Sub

 

[tygrrboi]

another option

Sub Group_and_Concat()
Dim i As Integer, j As Integer, c As Integer, lastrow As Integer
Dim v As Variant


With ActiveSheet
    lastrow = .Cells(.Rows.Count, "[COLOR=#ee82ee]A[/COLOR]").End(xlUp).Row


    v = .Range("[COLOR=#ee82ee]A1:C[/COLOR]" & lastrow)
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("[COLOR=#ee82ee]A:A[/COLOR]"), SortOn:=xlSortOnValues, _
                                   Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("[COLOR=#ee82ee]A:C[/COLOR]")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    i = 1
    While i <= lastrow
        c = Application.WorksheetFunction.CountIf(.Range("[COLOR=#ee82ee]A1:A[/COLOR]" & lastrow), .Range("[COLOR=#ee82ee]A[/COLOR]" & i).Value)
        .Range("[COLOR=#ff0000]F[/COLOR]" & i).Value = .Range("[COLOR=#ee82ee]A[/COLOR]" & i).Value & " (" & c & ")"
        For j = 0 To c - 1
            .Range("[COLOR=#ff0000]G[/COLOR]" & i + j).Value = .Range("[COLOR=#ee82ee]B[/COLOR]" & i + j).Value & " (" & .Range("[COLOR=#ee82ee]C[/COLOR]" & i + j).Value & ")"
        Next j
        i = i + c
    Wend
    
    .Range("A1").Resize(lastrow, [COLOR=#ff8c00]3[/COLOR]) = v


End With


End Sub

This assumes you have data in only A B and C (total of 3 columns)
Change this if necessary.

This puts the results in columns F & G... change it to suit your needs.

 

[CHARRIS1]

Hi Osvaldo,

thanks for this - works great.

A few further questions.
1. Is there away to clear the previous data when I run the macro a second time - it appears to currently add additional rows each time I run it. However in reality this will feed into a report which will be updated each fortnight.
2. Is there the ability to add the count of each fruit next to the output?
3. As always I have shot myself in the foot by attempting to provide a simple example, but now do not understand the code you have given enough to be able to manipulate it to my needs.
In reality the sheet of data is 23 columns across and the individual columns I am trying to locate are N, Q & T (same order as above).

Thanks

 

[CHARRIS1]

Thanks tygrrboi.

Appreciate the alternative, however I am looking to have the column B output data in 1 cell, so Osvaldo's solution better fits my needs.

 

[Osvaldo Palmeiro]

Hi.
I made the changes to the code according to what I understood from your questions. Please, see if the result has improved.

Sub LookUpConcatV2()
 Dim wsO As Worksheet, wsD As Worksheet, LR As Long, k As Long, c As Range, frstAddress As String
  Set wsO = Sheets("Sheet1"): Set wsD = Sheets("Sheet2")
     wsD.[A:B] = ""
     For k = 1 To wsO.Cells(Rows.Count, 14).End(3).Row
      If Application.CountIf(wsO.Range("N1:N" & k), wsO.Cells(k, 14)) > 1 Then GoTo nextfruit
      Set c = wsO.Range("N1:N" & wsO.Cells(Rows.Count, 14).End(3).Row).Find(wsO.Cells(k, 1), Lookat:=xlWhole)
       If Not c Is Nothing Then
         frstAddress = c.Address
          LR = wsD.Cells(Rows.Count, 1).End(3).Row
          wsD.Cells(LR + 1, 1) = c.Value & " (" & Application.CountIf(wsO.[N:N], c.Value) & ")"
           Do
            If wsD.Cells(LR + 1, 2) = "" Then
              wsD.Cells(LR + 1, 2) = c.Offset(, 3).Value & " (" & c.Offset(, 6).Value & ")"
            Else
             wsD.Cells(LR + 1, 2) = wsD.Cells(LR + 1, 2) & Chr(10) & _
              c.Offset(, 3).Value & " (" & c.Offset(, 6).Value & ")"
            End If
            Set c = wsO.Range("N1:N" & wsO.Cells(Rows.Count, 14).End(3).Row).FindNext(c)
           Loop While Not c Is Nothing And c.Address <> frstAddress
       End If
nextfruit:
     Next k
End Sub

 

[CHARRIS1]

Hi Osvaldo,

I received an email to say you responded on this thread, however looks like the forum was having some issues yesterday. In any case, your last update is not showing.

Thanks

 

[Osvaldo Palmeiro]

Ok. Refering to your earlier post (which was lost too), that no data had been replicated, this was due that I forgot to change the column reference of the source cell from A to N, so ".Cells(k, 1)" should be ".Cells(k, 14)".
Please try after you add a #4 to the command line as below, and sorry for that.

Set c = wsO.Range("N1:N" & wsO.Cells(Rows.Count, 14).End(3).Row).Find(wsO.Cells(k, 14), Lookat:=xlWhole)

 

[CHARRIS1]

Hi Osvaldo - works a charm.

Thank you!