Help with duplicate values move horizontally

sakis_s

New Member
Joined
Sep 22, 2019
Messages
9
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?

Your help is much appreciated.

Thank you very much for your time.
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
16,669
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)
    .AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("D1"), unique:=True
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
Joined
Sep 22, 2019
Messages
9
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)
    .AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("D1"), unique:=True
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! :ROFLMAO:
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
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
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
Just re-reading this thread and noticed that you originally asked for a formula to do this.
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
Joined
Sep 22, 2019
Messages
9
Just re-reading this thread and noticed that you originally asked for a formula to do this.
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


ABCDEFGH
1







2204089954Z4
204089954Z4


320378403185
2037840318544557860
420378404455
203832831239999

520378407860
203819014B3


620383283123





720383289999





8203819014B3






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

Spreadsheet Formulas
CellFormula
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
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
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
Joined
Sep 22, 2019
Messages
9
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
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
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
Joined
Sep 22, 2019
Messages
9
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! :)
 

Forum statistics

Threads
1,082,367
Messages
5,365,028
Members
400,819
Latest member
Gossow

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top