Data conversion from different rows to a single row for the same data input in the column A

[Nagoo]

Hi I am new to excel vba, I have data in the below format where there are multiple values against a single entry in A column. I wish to bring all the values against the same value in A column to its right. and avoid duplication.

Can you pls help me with a code?

Input data:

A	134​
A	12345​
A	567​
A	990​
B	123​	22​	33​
B	444​

Expected Output

A	134​	12345​	567​	990​
B	123​	22​	33​	444​

Thanks for the prompt support.

 

[Joe4]

Is your data already sorted by the first column (so all the values that need to be on the same line are "lumped together consecutively", like in your original image?
What row does your data start on?

 

[Joe4]

OK, assuming that your data is already sorted to start, and your data begins in cell A2, this code should do what you want:

Sub MyFormatData()

    Dim lr As Long
    Dim r As Long
    Dim lc As Long
    
    Application.ScreenUpdating = False
    
'   Find last row with data in columnn A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through range backwards
    For r = lr To 2 Step -1
'       see if value in column A is the same as the row above it
        If Cells(r, "A") = Cells(r - 1, "A") Then
'           Find last populated column in current row
            lc = Cells(r, Columns.Count).End(xlToLeft).Column
'           Copy values to row above
            Range(Cells(r, 2), Cells(r, lc)).Cut Cells(r - 1, Columns.Count).End(xlToLeft).Offset(0, 1)
'           Delete row
            Rows(r).Delete
        End If
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[Nagoo]

Sub MyFormatData() Dim lr As Long Dim r As Long Dim lc As Long Application.ScreenUpdating = False ' Find last row with data in columnn A lr = Cells(Rows.Count, "A").End(xlUp).Row ' Loop through range backwards For r = lr To 2 Step -1 ' see if value in column A is the same as the row above it If Cells(r, "A") = Cells(r - 1, "A") Then ' Find last populated column in current row lc = Cells(r, Columns.Count).End(xlToLeft).Column ' Copy values to row above Range(Cells(r, 2), Cells(r, lc)).Cut Cells(r - 1, Columns.Count).End(xlToLeft).Offset(0, 1) ' Delete row Rows(r).Delete End If Next r Application.ScreenUpdating = True End Sub

Thanks for the code - unfortunately the data is not sorted. A might once again repeat after B and vice versa as well. Appologies for not mentioning earlier.
Could u pls consider this as well and provide codes?

 

[Nagoo]

Is your data already sorted by the first column (so all the values that need to be on the same line are "lumped together consecutively", like in your original image?
What row does your data start on?

1. DAta is not sorted.
2. Data starts from 2nd row. (Cell A2)

 

[Joe4]

This should do what you want:

Sub MyFormatData()

    Dim lr As Long
    Dim r As Long
    Dim lc As Long
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
'   Find last row with data in columnn A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Build range to sort
    Set rng = Range("A2:B" & lr)
    
'   Sort range by column A
    rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
    
'   Loop through range backwards
    For r = lr To 2 Step -1
'       see if value in column A is the same as the row above it
        If Cells(r, "A") = Cells(r - 1, "A") Then
'           Find last populated column in current row
            lc = Cells(r, Columns.Count).End(xlToLeft).Column
'           Copy values to row above
            Range(Cells(r, 2), Cells(r, lc)).Cut Cells(r - 1, Columns.Count).End(xlToLeft).Offset(0, 1)
'           Delete row
            Rows(r).Delete
        End If
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[Nagoo]

Hi, The last code does not work properly.

Data is getting mismatched. I believe during sorting. It reports an issue. Where only few cells are shifting during sort. Pls check

I think it sorts only till B column

 

[Joe4]

It works fine for me. I suspect maybe you have some sort of data issue, or something else you haven't told us (like errors in the data, formulas, in some cells, merged cells, etc).

Please upload a desensitized copy of your data to a file sharing site and provide a link to it here, so we can test it out on the exact same data you are trying.

 

[Nagoo]

Thanks for the codes.

I tried editing one code: It resulted very well. Which is:

Set rng = Range("A2:XFD" & lr)

 

[Joe4]

Thanks for the codes.

I tried editing one code: It resulted very well. Which is:

Set rng = Range("A2:XFD" & lr)

OK, I see. Yes, that line was just limiting to the first two columns. Sorry, should have gone out further.