# Thread: Help with duplicate values move horizontally Thanks:  5 Post #5345812 (1)Post #5345831 (1)Post #5345881 (1)Post #5345672 (1)Post #5346346 (1) Likes:  4 Post #5345812 (1)Post #5345831 (1)Post #5346222 (1)Post #5345672 (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.

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```

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!

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```

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

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?

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```

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?

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```

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!

## User Tag List

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts
•