# Help with duplicate values move horizontally

#### sakis_s

##### New Member
Hi!
I'm looking for a formula to do the following:

I have:

A
B
C
D
E
F
G
H
I
1
 2040899

<colgroup><col width="68"></colgroup><tbody>
</tbody>
 54Z4

<colgroup><col width="68"></colgroup><tbody>
</tbody>
2
 2037840

<colgroup><col width="68"></colgroup><tbody>
</tbody>
 3185

<colgroup><col width="68"></colgroup><tbody>
</tbody>
3
 2037840

<colgroup><col width="68"></colgroup><tbody>
</tbody>
 4455

<colgroup><col width="68"></colgroup><tbody>
</tbody>
4
 2037840

<colgroup><col width="68"></colgroup><tbody>
</tbody>

<colgroup><col width="68"></colgroup><tbody>
 7860

<colgroup><col width="68"></colgroup><tbody>
</tbody>
</tbody>
5
 2038328

<colgroup><col width="68"></colgroup><tbody>
</tbody>
 3123

<colgroup><col width="68"></colgroup><tbody>
</tbody>
6
2038328
 9999

<colgroup><col width="68"></colgroup><tbody>
</tbody>
7
 2038190

<colgroup><col width="68"></colgroup><tbody>
</tbody>
 14B3

<colgroup><col width="68"></colgroup><tbody>
</tbody>
8
9

<tbody>
</tbody>

And i need the following result:

 A B C D E F G H I 1 2040899 54Z4 2 2037840 3185 4455 7860 3 2038328 3123 9999 4 2038190 14B3 5 6 7 8 9

<tbody>
</tbody>

Removing duplicates from column A and entering Column B values from removed duplicates horizontally next to the first value.

Anyone has any idea how to do that?

Thank you very much for your time.

#### JoeMo

##### MrExcel MVP
Assuming the blank in B4 of your input data should be 7860, this will reconfigure the data starting in D1 to the format you want.
Code:
``````Sub sakis_s()
'assumes first data entry is in cell A1
' Reformatted data begin in cell D1
Dim R As Range, Vin As Variant, Vunique As Variant, Vout As Variant, i As Long, j As Long
Dim Cols As Long
Set R = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To UBound(Vin, 1))
Application.ScreenUpdating = False
Range("D1").CurrentRegion.ClearContents
Rows(1).Insert
[A1] = "HDR"
With R.Columns(1).Offset(-1, 0).Resize(R.Rows.Count + 1)
End With
Rows(1).Delete
Vunique = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
For i = 1 To UBound(Vunique, 1)
For j = 1 To UBound(Vin, 1)
If Vin(j, 1) = Vunique(i, 1) Then
ct = ct + 1
If ct > Cols Then Cols = ct
Vout(i, ct) = Vin(j, 2)
End If
Next j
ct = 0
Next i
Range(Cells(1, "E"), Cells(UBound(Vout, 1), Cols + Columns("E").Column)).Value = Vout
Application.ScreenUpdating = True
End Sub``````

#### sakis_s

##### New Member
Assuming the blank in B4 of your input data should be 7860, this will reconfigure the data starting in D1 to the format you want.
Code:
``````Sub sakis_s()
'assumes first data entry is in cell A1
' Reformatted data begin in cell D1
Dim R As Range, Vin As Variant, Vunique As Variant, Vout As Variant, i As Long, j As Long
Dim Cols As Long
Set R = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
Vin = R.Value
ReDim Vout(1 To UBound(Vin, 1), 1 To UBound(Vin, 1))
Application.ScreenUpdating = False
Range("D1").CurrentRegion.ClearContents
Rows(1).Insert
[A1] = "HDR"
With R.Columns(1).Offset(-1, 0).Resize(R.Rows.Count + 1)
End With
Rows(1).Delete
Vunique = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
For i = 1 To UBound(Vunique, 1)
For j = 1 To UBound(Vin, 1)
If Vin(j, 1) = Vunique(i, 1) Then
ct = ct + 1
If ct > Cols Then Cols = ct
Vout(i, ct) = Vin(j, 2)
End If
Next j
ct = 0
Next i
Range(Cells(1, "E"), Cells(UBound(Vout, 1), Cols + Columns("E").Column)).Value = Vout
Application.ScreenUpdating = True
End Sub``````
Wow Joe! That was really amazing! I can't thank you enough! I really appreciate your time, it works perfectly!

#### Peter_SSs

##### MrExcel MVP, Moderator
Another way that you could consider
Code:
``````Sub Rearrange()
Dim d As Object
Dim a As Variant
Dim i As Long

Set d = CreateObject("Scripting.Dictionary")
a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
For i = 1 To UBound(a)
d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2)
Next i
Range("D1:E1").Resize(d.Count).Value = Application.Transpose(Array(d.Keys, d.Items))
Range("E1").Resize(d.Count).TextToColumns DataType:=xlDelimited, Semicolon:=True, FieldInfo:=Array(Array(1, 9))
End Sub``````

#### Peter_SSs

##### MrExcel MVP, Moderator
If you are interested, that can be done & for this I have assumed a heading row with data starting in row 2.
D2 is copied down as far as you might ever need.
E2 is copied across as far as you might ever need and down as far as the column D formula.

Excel Workbook
ABCDEFGH
1
2204089954Z4
3203784031852037840318544557860
420378404455203832831239999
520378407860203819014B3
620383283123
720383289999
8203819014B3
 Summary

#### sakis_s

##### New Member
If you are interested, that can be done & for this I have assumed a heading row with data starting in row 2.
D2 is copied down as far as you might ever need.
E2 is copied across as far as you might ever need and down as far as the column D formula.

Summary

 A B C D E F G H 1 2 2040899 54Z4 2040899 54Z4 3 2037840 3185 2037840 3185 4455 7860 4 2037840 4455 2038328 3123 9999 5 2037840 7860 2038190 14B3 6 2038328 3123 7 2038328 9999 8 2038190 14B3

<colgroup><col style="font-weight:bold; width:30px; "><col style="width:68px;"><col style="width:49px;"><col style="width:32px;"><col style="width:68px;"><col style="width:49px;"><col style="width:47px;"><col style="width:47px;"><col style="width:25px;"></colgroup><tbody>
</tbody>

 Cell Formula D2 =IFERROR(INDEX(\$A\$2:\$A\$8,MATCH(0,INDEX(COUNTIF(\$D\$1:D1,\$A\$2:\$A\$8)+(A\$2:A\$8=""),0),0)),"") E2 =IFERROR(INDEX(\$B\$2:\$B\$8,AGGREGATE(15,6,(ROW(\$B\$2:\$B\$8)-ROW(\$B\$2)+1)/(\$A\$2:\$A\$8=\$D2),COLUMNS(\$E2:E2))),"")

<tbody>
</tbody>

<tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4
That's an amazing solution as well! Thanks you so much for this function Peter! Script seems to work easier in my situation!

By the way, is there any way to also make the exact opposite using a script?

#### Peter_SSs

##### MrExcel MVP, Moderator
Script seems to work easier in my situation!
OK, so you have a couple of those to choose from.

By the way, is there any way to also make the exact opposite using a script?
Sure, if you started with the results above in columnd D, E, F, ... and columns A:C blank then try

Code:
``````Sub Make_List()
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long

a = Range("D1").CurrentRegion.Value
ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 2)
For i = 1 To UBound(a)
For j = 2 To UBound(a, 2)
If Len(a(i, j)) > 0 Then
k = k + 1
b(k, 1) = a(i, 1): b(k, 2) = a(i, j)
End If
Next j
Next i
Range("A1").Resize(k, 2).Value = b
End Sub``````

#### sakis_s

##### New Member
OK, so you have a couple of those to choose from.

Sure, if you started with the results above in columnd D, E, F, ... and columns A:C blank then try

Code:
``````Sub Make_List()
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long

a = Range("D1").CurrentRegion.Value
ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 2)
For i = 1 To UBound(a)
For j = 2 To UBound(a, 2)
If Len(a(i, j)) > 0 Then
k = k + 1
b(k, 1) = a(i, 1): b(k, 2) = a(i, j)
End If
Next j
Next i
Range("A1").Resize(k, 2).Value = b
End Sub``````
That works perfectly too!
Thank you so much Peter!

Just noticed one thing:
Some cells are formatted as text and have leading zeros:
e.g. "0700", "0010" etc.

Macro when pastes to new cells, changes the format and i'm loosing the leading zeros. Do you know why is this happening?

<colgroup><col width="420"></colgroup><tbody>
</tbody>

<colgroup><col width="420"></colgroup><tbody>
</tbody>

#### Peter_SSs

##### MrExcel MVP, Moderator
Try making this change near the end of the macro
Code:
``````<del>Range("A1").Resize(k, 2).Value = b</del>
With Range("A1").Resize(k, 2)
.NumberFormat = "@"
.Value = b
End With``````

#### sakis_s

##### New Member
Another way that you could consider
Code:
``````Sub Rearrange()
Dim d As Object
Dim a As Variant
Dim i As Long

Set d = CreateObject("Scripting.Dictionary")
a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
For i = 1 To UBound(a)
d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2)
Next i
Range("D1:E1").Resize(d.Count).Value = Application.Transpose(Array(d.Keys, d.Items))
Range("E1").Resize(d.Count).TextToColumns DataType:=xlDelimited, Semicolon:=True, FieldInfo:=Array(Array(1, 9))
End Sub``````
Yes! Now copies values as text! Perfect! Can you help me with your previous script too? I really appreciate your help Peter!