Unable to Merge Uneven Cells in Excel

[jpmayekar]

Hi,
I have a problem. I have around 300 Rows of data with uneven cells in different columns as below

A	B		D	E
1	x1	Expected Output	1	x1 x2
	x2
2	y1		2	y1 y2 y3
	y2
	y3
3	z1		3	z1
4	u1		4	u1 u2 u3 u4 u5
	u2
	u3
	u4
	u5

<tbody>
</tbody>

Columns A and B are input and Column C and D are Expected Output.

Please note Merging cells result in loss of Data. Welcome any suggestion on this and thanks before hand

 

[thisoldman]

This is done manually, with no VBA automation. It only works with text, not with formulas or numbers.

Widen column E so that it can contain the complete joined string. Select the cells you want to merge. From the Home tab, select Fill>> Justify.

 

[Fluff]

As long as you don't have a formulae in Col A, here is a VBA approach

Sub copytrans()

    Dim Cl As Range
    Dim arr As Variant
    
    For Each Cl In Columns(1).SpecialCells(xlBlanks).Areas
        arr = Cl.Offset(-1, 1).Resize(Cl.Rows.Count + 1)
        Cl.Offset(-1, 2).Value = Cl.Offset(-1).Value
        Cl.Offset(-1, 3).Resize(1) = Join(Application.Transpose(arr), " ")
    Next Cl

End Sub

 

[jpmayekar]

This is done manually, with no VBA automation. It only works with text, not with formulas or numbers.

Widen column E so that it can contain the complete joined string. Select the cells you want to merge. From the Home tab, select Fill>> Justify.

This does not work

 

[jpmayekar]

This bring all column data in 1 row such as x1 x2 y1 y2 y3 z1 u1 u2....

 

[jpmayekar]

Excel is available here to try out https://iclarityit-my.sharepoint.co...ygk9FPsXJ0&e=00a0f5c9eb32482697642b8920d1eee4

 

[jpmayekar]

https://iclarityit-my.sharepoint.co...2prv8B4gfo&e=9c683e77076043888c3e91de8e7cbb14

 

[Fluff]

For future reference, it makes life a lot simpler & easier, if you tell us the correct layout of your data.
This works with your test file

Sub copytrans()

    Dim Cl As Range
    Dim Arr As Variant
    Dim UsdRws As Long

    UsdRws = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Range("A1:B" & UsdRws).UnMerge
    For Each Cl In Range("A2:A" & UsdRws).SpecialCells(xlBlanks).Areas
        Arr = Cl.Offset(-1, 1).Resize(Cl.Rows.Count + 1)
        Cl.Offset(-1, 3).Resize(1).Value = Join(Application.Transpose(Arr), " ")
        Arr = Cl.Offset(-1, 2).Resize(Cl.Rows.Count + 1)
        Cl.Offset(-1, 4).Resize(1) = Join(Application.Transpose(Arr), " ")
    Next Cl

End Sub

 

[jpmayekar]

Excellent!!!!!!!!!!!!!

For future reference, it makes life a lot simpler & easier, if you tell us the correct layout of your data.
This works with your test file

Sub copytrans()

    Dim Cl As Range
    Dim Arr As Variant
    Dim UsdRws As Long

    UsdRws = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Range("A1:B" & UsdRws).UnMerge
    For Each Cl In Range("A2:A" & UsdRws).SpecialCells(xlBlanks).Areas
        Arr = Cl.Offset(-1, 1).Resize(Cl.Rows.Count + 1)
        Cl.Offset(-1, 3).Resize(1).Value = Join(Application.Transpose(Arr), " ")
        Arr = Cl.Offset(-1, 2).Resize(Cl.Rows.Count + 1)
        Cl.Offset(-1, 4).Resize(1) = Join(Application.Transpose(Arr), " ")
    Next Cl

End Sub

 

[jpmayekar]

Sub ninerows()'' ninerows Macro'' Keyboard Shortcut: Ctrl+Shift+D'    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1],R[1]C[-1],R[2]C[-1],R[3]C[-1],R[4]C[-1],R[5]C[-1],R[6]C[-1],R[7]C[-1],R[8]C[-1])"   End Sub

I was working on this code. It worked