Merge rows

[Blessy Clara]

Hi All,

I have a list of records

3 <tbody> </tbody>	Youth Services <tbody> </tbody>
3 <tbody> </tbody>	Family / Whanau Services <tbody> </tbody>
3 <tbody> </tbody>	Family Violence <tbody> </tbody>
3 <tbody> </tbody>	Education and Training <tbody> </tbody>
6 <tbody> </tbody>	Family / Whanau Services <tbody> </tbody>
6 <tbody> </tbody>	Basic Needs <tbody> </tbody>
6 <tbody> </tbody>	Education and Training <tbody> </tbody>
15 <tbody> </tbody>	Family / Whanau Services <tbody> </tbody>
15 <tbody> </tbody>	Health <tbody> </tbody>

<tbody>
</tbody>

I would like to merge rows based on the Index number into Single Row as given below

3	Youth Services, Family / Whanau Services, Family Violence, Education and Training <tbody> </tbody>
6	Family / Whanau Services, Basic Needs <tbody> </tbody>
15	Family / Whanau Services, Health

<tbody>
</tbody>

Thank you

 

[footoo]

Are there any blank rows within the data? If yes, is it OK to delete those rows?

 

[Blessy Clara]

Footoo - Thank you for your response, Nope Blank rows.

 

[footoo]

Here's a macro based upon built-in XL tools and functions :

Sub IMerge()
Dim rng As Range
Application.ScreenUpdating = False
On Error Resume Next
Range([A2], Cells(Rows.Count, "A").End(xlUp)) _
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Set rng = Range([A2], Cells(Rows.Count, "A").End(xlUp))
rng.Offset(0, 2).Formula = "=IF(A2<>A3,0,""d"")"
rng.Offset(0, 3).Formula = "=IF(A2<>A1,B2,D1 & "", "" & B2)"
With rng.Offset(0, 2).Resize(, 2)
    .Value = .Value
End With
On Error Resume Next
rng.Offset(0, 2).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
On Error GoTo 0
[B:C].Delete
End Sub

 

[footoo]

Cleaned-up a bit :

Sub IMerge()
Dim rng As Range
Application.ScreenUpdating = False
On Error Resume Next
Range([A2], Cells(Rows.Count, "A").End(xlUp)) _
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Set rng = Range([A2], Cells(Rows.Count, "A").End(xlUp)).Offset(0, 2)
rng.Formula = "=IF(A2<>A3,0,""d"")"
rng.Offset(0, 1).Formula = "=IF(A2<>A1,B2,D1 & "", "" & B2)"
With rng.Resize(, 2)
    .Value = .Value
End With
On Error Resume Next
rng.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
On Error GoTo 0
[B:C].Delete Shift:=xlToLeft
End Sub

 

[Blessy Clara]

Wow, Thanks alot. It is very helpful

 

[Mike Szczesny]

Can you use this? I created a simple example from your format. Assume your number range is A1:A7, your services range is B1:B7, Assume Number field is in C1. Assume Description field is in D1. Put formula to find unique items in C2. Use Cntrl+Shift+Enter and copy down. This formula is

=INDEX($A$1:$A$7,MATCH(0,COUNTIF($C$1:C1,$A$1:$A$7),0)) Place formula for numbers in D2. This formula first concatenates the descriptions matching a given number. The concatenation formula will produce FALSE for those numbers that do not match. Then I use a substitute formula to remove the "FALSE" results with "". This formula is below. Before entering you need to highlight the transpose part of the formula all the way to the second ). Highlight wit your mouse. Hit F9. The remove both { and }. Hit enter. Because of this additional step, you will not be able to copy down. =substitute(concatenate(transpose(if($A$1:$A$7=$C$2,$B$1:$B$7&" / "))),"FALSE","") <tbody> </tbody> 3 a Number Description 3 b 3 a / b / c / 3 c 6 6 d 15 6 e 15 f 15 g <colgroup><col span="3"><col></colgroup><tbody> </tbody>

<tbody>
</tbody>

 

[Blessy Clara]

Mike Szczesny - Thank you for your efforts and time,