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
MS001
MS001
MS001
MS001
MS001	9609992380
MS001	377 906 309C
MS002
MS002
MS002
MS002

<tbody>
[TD="align: center"]8[/TD]

[TD="align: right"]46531222[/TD]

[TD="align: center"]9[/TD]

[TD="align: right"]60811067[/TD]

[TD="align: center"]10[/TD]

[TD="align: right"]60814507[/TD]

[TD="align: center"]11[/TD]

[TD="align: right"]500309838[/TD]

[TD="align: center"]12[/TD]

[TD="align: center"]13[/TD]

[TD="align: center"]14[/TD]

[TD="align: right"]60811534[/TD]

[TD="align: center"]15[/TD]

[TD="align: right"]16137039[/TD]

[TD="align: center"]16[/TD]

[TD="align: right"]5234313[/TD]

[TD="align: center"]17[/TD]

[TD="align: right"]33000153[/TD]

</tbody>

Sheet1​

After Code

Excel 2010

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

<tbody>
[TD="align: center"]2[/TD]

[TD="align: center"]3[/TD]

</tbody>

Sheet2​

 

[Dazzawm]

Mick?

 

[MickG]

There is a "Typo", add comma shown in Red.
Not quite sure why you have a Type Mismatch, Maybe its your data.
Try on your thread data first

.Add Dn.Value, Dn.Offset([SIZE=5][COLOR=#ff0000][B],[/B][/COLOR] [/SIZE]1).Value

 

[hiker95]

Dazzawm,

Sample worksheets:

Excel 2007
	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
18
Sheet1

Excel 2007
	A	B
2
3
4
Sheet2

After the macro in worksheet Sheet2:

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

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData()
' hiker9, 11/14/2014, ME818208
Dim c As Range, rng As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
  Set rng = .Range(.Range("A8"), .Range("A" & Rows.Count).End(xlUp))
  With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each c In rng
      If Not .Exists(c.Value) Then
        .Add c.Value, c.Offset(, 1).Value
      Else
        .Item(c.Value) = .Item(c.Value) & "/ " & c.Offset(, 1).Value
      End If
    Next
    Sheets("Sheet2").Range("A2").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
  End With
End With
With Sheets("Sheet2")
  .Columns(1).Resize(, 2).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

 

[Dazzawm]

Thanks Mick and hiker but I still get a type mismatch on both codes.

 

[MickG]

Perhaps you need to post your file with "Box"

 

[Dazzawm]

Here is the file.

https://www.dropbox.com/s/e7n73mwknpozvjt/data.xlsx?dl=0

 

[MickG]

Try this:-
I think the "Transpose" function had found its limitation !!!

[COLOR=Navy]Sub[/COLOR] MG14Nov32
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A8"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        Dic.Add Dn.Value, Dn.Offset(, 1).Value
    [COLOR=Navy]Else[/COLOR]
        Dic.Item(Dn.Value) = Dic.Item(Dn.Value) & "/ " & Dn.Offset(, 1).Value
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]Dim[/COLOR] k
[COLOR=Navy]Dim[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]c=1
For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] Dic.keys
    [COLOR=Navy]With[/COLOR] Sheets("sheet2")
        c = c + 1
        .Range("A" & c) = k
        .Range("B" & c) = Dic.Item(k)
    [COLOR=Navy]End[/COLOR] With
[COLOR=Navy]Next[/COLOR] k
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[DocAElstein]

Hi Dazzawm.
. I started….. So I finished. The Profi’s beat me to it (again)…

. But just for Fun, my Beginner’s attempt.

CODE:

[color=darkblue]Option[/color] [color=darkblue]Explicit[/color]
[color=darkblue]Sub[/color] ConcatenateData()
[color=green]' Scripting a Runtime "Dictionary" Here just a convinient quick way to assign a unique item MS___ to a unique key 1 2 3 etc.[/color]
[color=green]'--requires library reference to MS Scripting Runtime (Early Binding)[/color]
[color=green]'        Tools>>References>>scroll down and check the box next to Microsoft Scripting Runtime[/color]
[color=green]'  ..Or crashes at next line.....[/color]
[color=green]' Dim dicLookupTable As Scripting.Dictionary 'Data held with a unique "Key" or Part Number.[/color]
[color=green]' Set dicLookupTable = New Scripting.Dictionary[/color]
[color=green]' The next two lines are an alternative called Late binding.[/color]
[color=darkblue]Dim[/color] dicLookupTable [color=darkblue]As[/color] [color=darkblue]Object[/color]
[color=darkblue]Set[/color] dicLookupTable = CreateObject("Scripting.Dictionary") [color=green]'a place to store MS001,MS002 etc. as unique items with a "key" 1, 2 etc.[/color]
 
[color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet, wks2 [color=darkblue]As[/color] Worksheet [color=green]' Give Abbreviations all properties and method of Object Worksheet[/color]
[color=darkblue]Set[/color] wks1 = Worksheets("Sheet1")
[color=darkblue]Set[/color] wks2 = Worksheets("Sheet2")
 
[color=darkblue]Let[/color] dicLookupTable.CompareMode = vbTextCompare
[color=darkblue]Dim[/color] Inary() [color=darkblue]As[/color] [color=darkblue]Variant[/color], Oaray() [color=darkblue]As[/color] [color=darkblue]Variant[/color] [color=green]'Input and Output arrays there values can be Variant type: anything (within reason)[/color]
[color=darkblue]Dim[/color] ConcanString [color=darkblue]As[/color] String [color=green]'Each line to go in column 2 of output[/color]
[color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color], ORow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]' number for Row count, Output Row Number[/color]
[color=darkblue]Dim[/color] LDRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'last Input Data Row[/color]
LDRow = wks1.Cells(Rows.Count, 1).End(xlUp).Row [color=green]'Find last row column 1, set by the C's[/color]
Inary = wks1.Range(wks1.Cells(1, 1), wks1.Cells(LDRow, 2)).Value  [color=green]' "Capture" Input data in an array in one go[/color]
[color=darkblue]ReDim[/color] Oaray(1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](Inary, 1), 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](Inary, 2)) [color=green]'Output Array is much too big.. as big as if only unique values in column 1[/color]
 
  [color=darkblue]For[/color] i = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](Inary, 1)  [color=green]'Going along the rows to upper bound of Input array row[/color]
      [color=darkblue]If[/color] dicLookupTable.Exists(Inary(i, 1)) [color=darkblue]Then[/color] [color=green]'If we have already made an entry at this point in the dictionary so - want to concatenate.[/color]
         ConcanString = ConcanString & Inary(i, 2) & " / "
         Oaray(ORow, 2) = ConcanString
      [color=darkblue]Else[/color] [color=green]'Assign a new unique value[/color]
        ORow = ORow + 1 [color=green]'New Row for Output[/color]
        dicLookupTable.Item((Inary(i, 1))) = ORow [color=green]'Put an item in the dictionary the item is in the (), j is the count or unique "key"[/color]
        Oaray(ORow, 1) = Inary(i, 1) [color=green]'Put unique row number in first colum of output array[/color]
        ConcanString = Inary(i, 2) & " / " [color=green]'First concantanated number for this unique row[/color]
      [color=darkblue]End[/color] [color=darkblue]If[/color]
  [color=darkblue]Next[/color] i
 
[color=darkblue]Let[/color] wks2.Cells(1, 1).Resize(UBound(Oaray, 1), [color=darkblue]UBound[/color](Oaray, 2)).Value = Oaray [color=green]'Resize Output Range to otput array and make it equal to output Array[/color]
wks2.Columns(2).Resize(, UBound(Oaray, 2)).AutoFit
  [color=darkblue]For[/color] i = 1 [color=darkblue]To[/color] wks2.Cells(Rows.Count, 1).End(xlUp).Row [color=green]' For Output Rows[/color]
    [color=darkblue]Let[/color] wks2.Cells(i, 2).Value = Left(wks2.Cells(i, 2).Value, Len(wks2.Cells(i, 2).Value) - 3) [color=green]'Strip off last /[/color]
  [color=darkblue]Next[/color] i
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'ConcatenateData()[/color]

Takes this:

Book1
	A	B
1	MS001	46531222
2	MS001	60811067
3	MS001	60814507
4	MS001	500309838
5	MS001	9609992380
6	MS001	377 906 309C
7	MS002	60811534
8	MS002	16137039
9	MS002	5234313
10	MS002	33000153
Sheet1

And gives you this:

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

. It works I think similar to Mike’s and Hiker’s so probably you will get the same error….

.Alan

 

[Dazzawm]

Try this:-
I think the "Transpose" function had found its limitation !!!
Regards Mick

Thanks Mick that worked, but why above it wasn't that bigger file?

 

[Dazzawm]

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