# Thread: Help with duplicate values move horizontally Thanks:  5 Post #5345831 (1)Post #5345881 (1)Post #5345672 (1)Post #5346346 (1)Post #5345812 (1) Likes:  4 Post #5345672 (1)Post #5345812 (1)Post #5345831 (1)Post #5346222 (1)

1. ## Help with duplicate values move horizontally

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

I have:

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

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

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.  Reply With Quote

2. ## Re: Help with duplicate values move horizontally

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```  Reply With Quote

3. ## Re: Help with duplicate values move horizontally Originally Posted by JoeMo 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!   Reply With Quote

4. ## Re: Help with duplicate values move horizontally

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```  Reply With Quote

5. ## Re: Help with duplicate values move horizontally

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

 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))),"")

Excel tables to the web >> Excel Jeanie HTML 4  Reply With Quote

6. ## Re: Help with duplicate values move horizontally Originally Posted by Peter_SSs 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

 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))),"")

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?  Reply With Quote

7. ## Re: Help with duplicate values move horizontally Originally Posted by sakis_s Script seems to work easier in my situation!
OK, so you have a couple of those to choose from.  Originally Posted by sakis_s 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```  Reply With Quote

8. ## Re: Help with duplicate values move horizontally Originally Posted by Peter_SSs 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?  Reply With Quote

9. ## Re: Help with duplicate values move horizontally

Try making this change near the end of the macro
Code:
```Range("A1").Resize(k, 2).Value = b
With Range("A1").Resize(k, 2)
.NumberFormat = "@"
.Value = b
End With```  Reply With Quote

10. ## Re: Help with duplicate values move horizontally Originally Posted by Peter_SSs 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!   Reply With Quote

## User Tag List

14b3, duplicate, duplicates, horizontal alignment, vlookup 