Code To Move From Vertical To Horizontal?

[Dazzawm]

I have sheet 1 as laid out below. Column A will have a list of numbers the same (then they change) with different numbers next to them. I need them to be put on sheet 2 with the numbers in column B next to them with a slash and a gap added, rather than in a list, like the result in sheet 2 and the same when the number in A changes and so on.... Thanks

Before Code

Excel 2010

	A	B
8	MS001	46531222
9	MS001	60811067
10	MS001	60814507
11	MS001	500309838
12	MS001	9609992380
13	MS001	377 906 309C
14	MS002	60811534
15	MS002	16137039
16	MS002	5234313
17	MS002	33000153

<tbody>
</tbody>

Sheet1​

After Code

Excel 2010

	A	B
2	MS001	46531222/ 60811067/ 60814507/ 500309838/ 9609992380/ 377 906 309C
3	MS002	60811534/ 16137039/ 5234313/ 33000153

<tbody>
</tbody>

Sheet2​

 

[DocAElstein]

Thanks you Adam, Mick, Hiker & Doc for all your input.

.. You are welcome........

...Btw... I tried your data. ..... My code is a bit messy and did not like having no data.... So I had to do a quick mod (shown in Red here):

Option ExplicitSub ConcatenateData()
' Scripting a Runtime "Dictionary" Here just a convinient quick way to assign a unique item MS___ to a unique key 1 2 3 etc.
'--requires library reference to MS Scripting Runtime (Early Binding)
'        Tools>>References>>scroll down and check the box next to Microsoft Scripting Runtime
'  ..Or crashes at next line.....
' Dim dicLookupTable As Scripting.Dictionary 'Data held with a unique "Key" or Part Number.
' Set dicLookupTable = New Scripting.Dictionary
' The next two lines are an alternative called Late binding.
Dim dicLookupTable As Object
Set dicLookupTable = CreateObject("Scripting.Dictionary") 'a place to store MS001,MS002 etc. as unique items with a "key" 1, 2 etc.


Dim wks1 As Worksheet, wks2 As Worksheet ' Give Abbreviations all properties and method of Object Worksheet
Set wks1 = Worksheets("Sheet1")
Set wks2 = Worksheets("Sheet2")


Let dicLookupTable.CompareMode = vbTextCompare
Dim Inary() As Variant, Oaray() As Variant 'Input and Output arrays there values can be Variant type: anything (within reason)
Dim ConcanString As String 'Each line to go in column 2 of output
Dim i As Long, ORow As Long ' number for Row count, Output Row Number
Dim LDRow As Long 'last Input Data Row
LDRow = wks1.Cells(Rows.Count, 1).End(xlUp).Row 'Find last row column 1, set by the C's
Inary = wks1.Range(wks1.Cells(1, 1), wks1.Cells(LDRow, 2)).Value  ' "Capture" Input data in an array in one go
ReDim Oaray(1 To UBound(Inary, 1), 1 To UBound(Inary, 2)) 'Output Array is much too big.. as big as if only unique values in column 1


  For i = 1 To UBound(Inary, 1)  'Going along the rows to upper bound of Input array row
      If dicLookupTable.Exists(Inary(i, 1)) Then 'If we have already made an entry at this point in the dictionary so - want to concatenate.
         ConcanString = ConcanString & Inary(i, 2) & " / "
         Oaray(ORow, 2) = ConcanString
      Else 'Assign a new unique value
        ORow = ORow + 1 'New Row for Output
        dicLookupTable.Item((Inary(i, 1))) = ORow 'Put an item in the dictionary the item is in the (), j is the count or unique "key"
        Oaray(ORow, 1) = Inary(i, 1) 'Put unique row number in first colum of output array
        ConcanString = Inary(i, 2) & " / " 'First concantanated number for this unique row
      End If
  Next i
  
Let wks2.Cells(1, 1).Resize(UBound(Oaray, 1), UBound(Oaray, 2)).Value = Oaray 'Resize Output Range to otput array and make it equal to output Array
wks2.Columns(2).Resize(, UBound(Oaray, 2)).AutoFit
  For i = 1 To wks2.Cells(Rows.Count, 1).End(xlUp).Row ' For Output Rows
[COLOR=#ff0000]    If wks2.Cells(i, 2).Value <> "" Then[/COLOR]
      Let wks2.Cells(i, 2).Value = Left(wks2.Cells(i, 2).Value, Len(wks2.Cells(i, 2).Value) - 3) 'Strip off last /
[COLOR=#ff0000]    Else ' Do not do the Left Function on an empty cell![/COLOR]
[COLOR=#ff0000]    End If[/COLOR]
  Next i
End Sub 'ConcatenateData()

... Then it works...

 

[hiker95]

Dazzawm,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.


MickG,

Thanks for the explanation, and, the macro code - a definite one for my archives - thanks again.

 

[MickG]

You're all welcome.

 

[DocAElstein]

MickG,.........
Thanks for the explanation, and, the macro code - a definite one for my archives - thanks again.

Mick, Hiker,
Thanks guys from me too. As allways learnt a lot from the Profi's again. If only one day I cando it so quick and professional like that!
. ...my attempt was based on wot I learnt from a recent hiker code!

 

[hiker95]

DocAElstein,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.

 

[DocAElstein]

Hi Dazzawm.


……….
. Another Code:

Option Explicit
[color=darkblue]Sub[/color] ConcatenateData2()
 Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off.[/color]
 [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] TheEnd [color=green]'If anything goes wrong go to the End instead of crashing.[/color]
 [color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet, wks2 [color=darkblue]As[/color] Worksheet [color=green]' Give Abbreviations[/color]
 [color=darkblue]Set[/color] wks1 = Worksheets("sheet1") [color=green]'then give all properties and method[/color]
 [color=darkblue]Set[/color] wks2 = Worksheets("sheet2") [color=green]'of Object Worksheet to them via .dot thing[/color]
 [color=darkblue]Dim[/color] Data1Row [color=darkblue]As[/color] [color=darkblue]Long[/color], LastData1Row [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Data1 Row Number, Last Data Row in wks1. long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
 [color=darkblue]Dim[/color] OutputDataRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Output Data Row[/color]
 [color=darkblue]Let[/color] OutputDataRow = 2 [color=green]'Start puting Output data in second Row[/color]
 [color=darkblue]Dim[/color] ConcanString [color=darkblue]As[/color] String [color=green]'Each line of concatenated Data 2to go in column 2 of output[/color]
 
 [color=green]'--------Make tempory sheet with unique values from Column A (Data1)[/color]
 [color=darkblue]Let[/color] Worksheets.Add(After:=wks1).Name = "Unique1" [color=green]'Add a Worksheet after the first, named Unique1 for now[/color]
 
 [color=darkblue]Let[/color] LastData1Row = wks1.Range("A" & Rows.Count).End(xlUp).Row
 wks1.Range("A1:A" & LastData1Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=[color=darkblue]True[/color] [color=green]'Copies only unique A Column (Data1) to first column in Tempory made "Unique1" sheet, The important bit is Unique:=True - that only copies unique bits[/color]
[color=green]'---------------------[/color]
 
[color=darkblue]Dim[/color] LastUnqRow [color=darkblue]As[/color] [color=darkblue]Long[/color], UqeRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Rows in Tempory Unique Sheet. long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
[color=darkblue]Let[/color] LastUnqRow = Worksheets("Unique1").Cells.Find(What:="*", After:=Worksheets("Unique1").Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=green]'Get last Unique Row for use in next loop. method: You starta at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers)[/color]
  [color=darkblue]For[/color] UqeRow = 2 [color=darkblue]To[/color] LastUnqRow [color=green]'Take each unique Data 1[/color]
   
    [color=darkblue]For[/color] Data1Row = 2 [color=darkblue]To[/color] LastData1Row [color=green]'go along each data row[/color]
      [color=darkblue]If[/color] wks1.Cells(Data1Row, 1).Value = Worksheets("Unique1").Cells(UqeRow, 1).Value [color=darkblue]Then[/color] [color=green]'We have amatch in Data1 to a unique Data name..[/color]
      [color=darkblue]Let[/color] ConcanString = ConcanString & wks1.Cells(Data1Row, 2).Value & " / " [color=green]'...So include that in the concatenated string and a " / "[/color]
      wks2.Cells(OutputDataRow, 1).Value = Worksheets("Unique1").Cells(UqeRow, 1).Value
      wks2.Cells(OutputDataRow, 2).Value = ConcanString
      [color=darkblue]Else[/color] [color=green]'No match so do nothing[/color]
      [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] Data1Row
   
    [color=darkblue]Let[/color] ConcanString = "" [color=green]'After all matches are found, Empty Concanstring of last matched and concastenated Data2 and...[/color]
      [color=darkblue]If[/color] wks2.Cells(OutputDataRow, 2).Value <> "" [color=darkblue]Then[/color] [color=green]'Assuming Data has been found...[/color]
      [color=darkblue]Let[/color] wks2.Cells(OutputDataRow, 2).Value = Left(wks2.Cells(OutputDataRow, 2).Value, Len(wks2.Cells(OutputDataRow, 2).Value) - 3) [color=green]'Strip off last /.....[/color]
      [color=darkblue]Else[/color] [color=green]' Do not do the Left Function on an empty cell![/color]
      [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Let[/color] OutputDataRow = OutputDataRow + 1 [color=green]'.... reset the next output row[/color]
 
  [color=darkblue]Next[/color] UqeRow
 
wks1.AutoFilterMode = [color=darkblue]False[/color] [color=green]'Need to reset this (I think?)[/color]
Application.DisplayAlerts = [color=darkblue]False[/color] [color=green]'Prevent being asked if you really want to delete Temporary Unique sheet[/color]
Sheets("Unique1").Delete [color=green]' delete the filtered Data name sheet as you do not need it any more[/color]
Application.DisplayAlerts = [color=darkblue]True[/color]
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Turn screen "back on" or screen is "dead"[/color]
[color=darkblue]Exit[/color] [color=darkblue]Sub[/color] [color=green]'We stop code here assuming it worked (or at least did not crash!)[/color]
TheEnd: [color=green]'Come here if error[/color]
wks1.AutoFilterMode = [color=darkblue]False[/color]
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Important to do this here so if anything goes wron then the screen updating is turned back on, ohterwisee the screen is dead[/color]
MsgBox (Err.Description) [color=green]'Print out error message in Message Box[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

… works as well. Different method: Makes a temporary sheet with unique Data1 in it; compares with the whole List for a match; Concatenates as before all matches in Data 2 in second output Column.

. Has the disadvantage that for lots of data it probably takes a bit longer. But it is an alternative, bit simpler to understand Method.

Alan
P.s. Simplified “Monochrome” version of code:

Sub ConcatenateData2b()
 
 Dim wks1 As Worksheet, wks2 As Worksheet
 Set wks1 = Worksheets("sheet1")
 Set wks2 = Worksheets("sheet2")
 
 Let OutputDataRow = 2
 Let Worksheets.Add(After:=wks1).Name = "Unique1"
 
 wks1.Range("A1:A" & wks1.Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=True
 
  For UqeRow = 2 To Worksheets("Unique1").Range("A" & Rows.Count).End(xlUp).Row
   
    For Data1Row = 2 To wks1.Range("A" & Rows.Count).End(xlUp).Row
      If wks1.Cells(Data1Row, 1).Value = Worksheets("Unique1").Cells(UqeRow, 1).Value Then
      wks2.Cells(OutputDataRow, 1).Value = Worksheets("Unique1").Cells(UqeRow, 1).Value
      wks2.Cells(OutputDataRow, 2).Value = wks2.Cells(OutputDataRow, 2).Value + wks1.Cells(Data1Row, 2).Value & " / "
      Else
      End If
    Next Data1Row
 
      If wks2.Cells(OutputDataRow, 2).Value <> "" Then
      Let wks2.Cells(OutputDataRow, 2).Value = Left(wks2.Cells(OutputDataRow, 2).Value, Len(wks2.Cells(OutputDataRow, 2).Value) - 3)
      Else
      End If
    Let OutputDataRow = OutputDataRow + 1
 
  Next UqeRow
 
wks1.AutoFilterMode = False
Application.DisplayAlerts = False
Sheets("Unique1").Delete
Application.DisplayAlerts = True
End Sub

…………………………………………………………..

P.s.2.

. If you change the code to comment out the bits that delete the tempory Unique sheet, like this….

[color=green]'Application.DisplayAlerts = False[/color]
[color=green]'Sheets("Unique1").Delete[/color]
[color=green]'Application.DisplayAlerts = True[/color]

…….. then you can apply adam087’s Function to that list of unique Data 1 values to get this sort of output:

Book1
	A	B
2	MS001	60814507/1563 J4/1920 J7/96092693/7714662/46531222/60811067/60814507/500309838/9609992380/377 906 309C
3	MS002	60811534/16137039/5234313/33000153/1920 4S/1920FC/5946 07/5946 09/16137039/7696064/1C1Y-9F479-AA/1144809/9 389 131/12 569 240/16 137 039/17112715/16017460/16137039/8161370390/39330-24750/816017460/816137039/8933000153/0K950-18-211/023 545 45 32/8 15 701/12 38 788/62 38 927/77 00 706 876/89 33 000 153/1378162/3411400
4	MS003	1648138/E6EF-9F479-A2A
5	MS005	030 906 051A
Unique1

Cell Formulas
Range	Formula
B2	=GROUPON(A2,sheet1!$A$2:$B$523,2,"/")
B3	=GROUPON(A3,sheet1!$A$2:$B$523,2,"/")
B4	=GROUPON(A4,sheet1!$A$2:$B$523,2,"/")
B5	=GROUPON(A5,sheet1!$A$2:$B$523,2,"/")

……….. so jet another alternative!


(……….Adam087 I expect could somehow include in his formula the bit to get at the unique values …

. So for example instead of
=GROUPON(A2,sheet1!$A$2:$B$523,2,"/")
…… something like
=GROUPON(SOMETHING_HERE_TO_GET_AT_THE_NEXT_UNIQUE_VALUE,sheet1!$A$2:$B$523,2,"/")

But That “SOMETHING_HERE_TO_GET_AT_THE_NEXT_UNIQUE_VALUE” is a number too high for me……)

 

[DocAElstein]

Copy the code in to a module in your workbook:............

Now you can use the function =GROUPON in your worksheet as shown.
.....
=GROUPON(group_key, table_array, col_index_num, [delim])[/code]

........

Thanks Adam.
Nice Function. Works great
Alan Elston

 

[DocAElstein]

Hi Again.

Hi Dazzawm

I've got a UDF I use for this kind of scenario. It should help you out.

……………………….

Thanks for your help but it’s going totally over my head.……… I need an idiot proof macro where I run it and it does it all for me!!!

. hows about anuver Method Then…. A VBA code that adds a sheet (called AdamFormula), puts in the unique Data 1 values in column A, then puts in Adam’s formula alongside in Column B…
. If You copy all the following codes (complete) in one go and paste it in a module in your File with the data in sheet 1, then run it it should give you this new sheet…

Book1
	A	B
1	UniqueData1	Concatenated Stuff
2	MS001	60814507 / 1563 J4 / 1920 J7 / 96092693 / 7714662 / 46531222 / 60811067 / 60814507 / 500309838 / 9609992380 / 377 906 309C
3	MS002	60811534 / 16137039 / 5234313 / 33000153 / 1920 4S / 1920FC / 5946 07 / 5946 09 / 16137039 / 7696064 / 1C1Y-9F479-AA / 1144809 / 9 389 131 / 12 569 240 / 16 137 039 / 17112715 / 16017460 / 16137039 / 8161370390 / 39330-24750 / 816017460 / 816137039 / 8933000153 / 0K950-18-211 / 023 545 45 32 / 8 15 701 / 12 38 788 / 62 38 927 / 77 00 706 876 / 89 33 000 153 / 1378162 / 3411400
4	MS003	1648138 / E6EF-9F479-A2A
5	MS005	030 906 051A
6	MS006	1920 0E / 1920 9H / 9618261580 / 96 18 261 580
7	MS007	027 998 041 1 / 036 906 051 / 036 906 051D / 036 998 041 1
AdamFormula

Cell Formulas
Range	Formula
B2	=GROUPON(A2,sheet1!$A$2:$B$523,2," / ")
B3	=GROUPON(A3,sheet1!$A$2:$B$523,2," / ")
B4	=GROUPON(A4,sheet1!$A$2:$B$523,2," / ")
B5	=GROUPON(A5,sheet1!$A$2:$B$523,2," / ")
B6	=GROUPON(A6,sheet1!$A$2:$B$523,2," / ")
B7	=GROUPON(A7,sheet1!$A$2:$B$523,2," / ")

………

The Code (there are 2 VBA .Formula versions there – both work, you only need one but I left them both in)

[color=darkblue]Option[/color] [color=darkblue]Explicit[/color]
[color=darkblue]Option[/color] [color=darkblue]Compare[/color] [color=darkblue]Text[/color]
[color=darkblue]Sub[/color] adam087FormularPutInWithVBAInNewsheetMethod()
 
[color=darkblue]Dim[/color] wkstLkUp [color=darkblue]As[/color] Worksheet [color=green]'Sheet 1 effectivelly ..[/color]
[color=darkblue]Set[/color] wkstLkUp = Worksheets("Sheet1") [color=green]'....is the Look Up Table[/color]
[color=darkblue]Dim[/color] LastData1 [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Last Data 1 Row in Data sheet (sheet 1)[/color]
[color=darkblue]Let[/color] LastData1 = wkstLkUp.Cells(Rows.Count, 1).End(xlUp).Row
[color=darkblue]Dim[/color] rngLkUp [color=darkblue]As[/color] Range [color=green]'look Up Range[/color]
[color=darkblue]Set[/color] rngLkUp = wkstLkUp.Range("A2:B" & LastData1)
 
[color=darkblue]Let[/color] Worksheets.Add(After:=wkstLkUp).Name = "AdamFormula"
 
wkstLkUp.Range("A2:A" & wkstLkUp.Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("AdamFormula").Range("A1"), Unique:=[color=darkblue]True[/color]
[color=darkblue]Dim[/color] wkstUqe [color=darkblue]As[/color] Worksheet
[color=darkblue]Set[/color] wkstUqe = ThisWorkbook.Worksheets("AdamFormula") [color=green]'Unique Data1 values sheet in main File[/color]
[color=darkblue]Dim[/color] rngData1Uqe [color=darkblue]As[/color] Range [color=green]' Unique Data 1 Column Values[/color]
[color=darkblue]Dim[/color] LastData1Uqe [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Last Unique Data 1[/color]
[color=darkblue]Let[/color] LastData1Uqe = wkstUqe.Cells(Rows.Count, 1).End(xlUp).Row
[color=darkblue]Set[/color] rngData1Uqe = wkstUqe.Range("A2:A" & LastData1Uqe)
 
  [color=darkblue]Dim[/color] rngBB [color=darkblue]As[/color] Range [color=green]'Abritrary chosen Column to put the adam Formual in using VBA to compare with Workshhet formula typed in Column B in Unique Data Sheet[/color]
  [color=darkblue]Set[/color] rngBB = wkstUqe.Range("B2:B" & LastData1Uqe) [color=green]'Chose Column B[/color]
  [color=darkblue]With[/color] rngBB
   [color=green]'#####  Worksheet Formula From adam    =GROUPON(A2;sheet1!$A$2:$B$523;2;"/")   ######[/color]
   .FormulaR1C1 = "=GROUPON(R[0]C[-1]," & rngLkUp.Address(ReferenceStyle:=xlR1C1, External:=True) & ",2,"" / "")"
 
   .Formula = "=GROUPON(" & rngData1Uqe(1, 1).Address(0, 0) & "," & rngLkUp.Address(External:=True) & ",2,"" / "")"
  
   [color=green]'.Value = .Value 'Removes Formula(Puts value in)[/color]
   [color=green]'.Replace What:=0, Replacement:="", LookAt:=xlWhole, SearchFormat:=False 'Get rid of zeros[/color]
 [color=darkblue]End[/color] [color=darkblue]With[/color]
    Worksheets("AdamFormula").Range("A1:B1").Value = Array("UniqueData1", "Concatenated Stuff") [color=green]'Put the headings in row 1. Good to do it here as often filtering stuff puts wot you do not want in the first row)[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'adam087FormularPut[color=darkblue]In[/color]WithVBA()[/color]
 
[color=darkblue]Public[/color] [color=darkblue]Function[/color] GROUPON(group_key [color=darkblue]As[/color] [color=darkblue]Variant[/color], table_array [color=darkblue]As[/color] Range, col_index_num [color=darkblue]As[/color] [color=darkblue]Long[/color], [color=darkblue]Optional[/color] delim [color=darkblue]As[/color] [color=darkblue]String[/color] = " ")
 
    Application.Volatile
 
    [color=darkblue]Dim[/color] s               [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] cell            [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] rangeToCheck    [color=darkblue]As[/color] Range
   
    [color=darkblue]With[/color] table_array
        [color=darkblue]Set[/color] rangeToCheck = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1))
    [color=darkblue]End[/color] [color=darkblue]With[/color]
   
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell In rangeToCheck
        [color=darkblue]If[/color] cell.Value = group_key [color=darkblue]Then[/color] s = s & cell.Offset(0, col_index_num - 1).Value & delim
    [color=darkblue]Next[/color] cell
   
    [color=darkblue]If[/color] Len(s) > 0 [color=darkblue]Then[/color] s = Left(s, Len(s) - Len(delim))
    GROUPON = s
 
[color=darkblue]End[/color] [color=darkblue]Function[/color]

Alan

P.s. Here is a link to the returned data File, mainly for my benefit as I find my Files sometimes easier to find here than in my chaotic Computer system at home!!
XL 2007 data.xlsm:
https://app.box.com/s/wkqnemkj40do3yfv7z0k
XL 2003 data.xls:
https://app.box.com/s/l5pjkvv70ko5t4mt59aj

Just remember if you play around with the macros.. Always make a back up copy of the file just before you run any Macro, as any changes done by a macro cannot be reversed as you can normal spreadsheet stuff.

 

[apo]

Here's another possibility...

Private Sub CommandButton1_Click()
    Dim x, y, Z, cnt As Long, i As Long, kk As Long
    x = Range("A1").CurrentRegion
    With CreateObject("scripting.dictionary")
        For j = LBound(x) To UBound(x)
            x0 = .Item(x(j, 1))
        Next
        Z = .keys
        ReDim y(1 To .Count, 1 To 2)
    End With
    cnt = 1
    For i = LBound(Z) To UBound(Z)
        y(i + 1, 1) = Z(i)
        kk = UBound(Filter(Application.Transpose(Application.Index(x, 0, 1)), Z(i), True, 1))
        y(i + 1, 2) = Join(Application.Index(x, Application.Transpose(Evaluate("row(" & cnt & ":" & cnt + kk & ")")), Application.Transpose([row(2:2)])), "/ ")
        cnt = cnt + kk + 1
    Next i
    Range("D1").Resize(UBound(y), 2).Value = y
End Sub

<b>Sheet1</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:64px;" /><col style="width:84px;" /><col style="width:64px;" /><col style="width:66px;" /><col style="width:470px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td><td >D</td><td >E</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td >MS001</td><td style="text-align:right; ">46531222</td><td > </td><td >MS001</td><td >46531222/ 60811067/ 60814507/ 500309838/ 9609992380/ 377 906 309C</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >MS001</td><td style="text-align:right; ">60811067</td><td > </td><td >MS002</td><td >60811534/ 16137039/ 5234313/ 33000153</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >MS001</td><td style="text-align:right; ">60814507</td><td > </td><td >MS003</td><td >423423/ 6453643/ 2432/ 76574585/ 3453/ 22</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >MS001</td><td style="text-align:right; ">500309838</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td >MS001</td><td style="text-align:right; ">9609992380</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td >MS001</td><td >377 906 309C</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td >MS002</td><td style="text-align:right; ">60811534</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >8</td><td >MS002</td><td style="text-align:right; ">16137039</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >9</td><td >MS002</td><td style="text-align:right; ">5234313</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >10</td><td >MS002</td><td style="text-align:right; ">33000153</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >11</td><td >MS003</td><td style="text-align:right; ">423423</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >12</td><td >MS003</td><td style="text-align:right; ">6453643</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >13</td><td >MS003</td><td style="text-align:right; ">2432</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >14</td><td >MS003</td><td style="text-align:right; ">76574585</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >15</td><td >MS003</td><td style="text-align:right; ">3453</td><td > </td><td > </td><td > </td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >16</td><td >MS003</td><td style="text-align:right; ">22</td><td > </td><td > </td><td > </td></tr></table> <br />Excel tables to the web - Excel Jeanie Html 4

 

[DocAElstein]

Here's another possibility...

...........

Hey apo,
Thanks that you added a nuver Code. I find it great when I am learning to have so many different ways of doing the same thing.
. I am still amazed (and somewot overwhelmed sometimes), how much can be squeezed into one line using the “dot” “OOP” programming techniques.
. Have the code up and running with the full data (just using it as a normal sub rather than Button thing). Works great by me with results similar to wot you showed. Have a feeling this one is going to take a considerable amount of time and brain ache for me to go through and understand later. But that is how I learn the most.
. Just at a very first glance I see you are extensively using VBA Application Transpose. I note that MickG in #17 gave a new code, as his original in #9 he thought might not work because of Transpose? Also I could only get hiker’s code (#13) to work on a small amount of the sample data and he is also using the Application Transpose? But you may be using it differently. Maybe it will become clear when I try to get my head down on the Code Later Today or Tomorrow.
. In the meantime I think we have a great selection of codes to get a vertical list with Duplicate names / (keys!) consolidated unique keys with entries concatenated in one cell. And thanks from me for another code!
Alan