VBA to merge cells based on value

**12588sam** · 05-05-2011, 04:53 AM

Hi guys,

I need some help with VBA to cycle through rows within a specified column and merge cells if the values are the same. For example, in the below, we would be merging rows 2/3, and then 4/5/6.

Column 1
Row 1 A
Row 2 B
Row 3 B
Row 4 C
Row 5 C
Row 6 C
Row 7 D
Row 8 E

Hope that makes sense, excuse the basic diagram.

Thanks

Sam

**snb** · 05-05-2011, 05:02 AM

sub snb()
    Sheets(1).Columns(1).AdvancedFilter xlFilterCopy, , Sheets(1).Cells(1, 2), True
    Sheets(1).Columns(1).Delete
End Sub

**12588sam** · 05-05-2011, 07:48 AM

Thanks for the reply, unfortunately its not quite what I'm looking for. Let me try and explain a little better, say I have the following structure:

Column 1 Column 2
Row 1 A A
Row 2 A B
Row 3 B A
Row 4 B B
Row 5 B C
Row 6 C A

I would need Column 1 / Rows 1/2 to merge into a single A value, whilst keeping both values A/B in column 2 - etc.

Hope that helps to clarify.

Thanks

Sam

**mohd9876** · 05-05-2011, 09:13 AM

Dear 12588sam,
please try the following code


Dim a As Range
Dim i
Application.DisplayAlerts = False
For Each a In Range("A1", Range("A65000").End(xlUp))
    For i = a.Row + 1 To Range("A65000").End(xlUp).Row
        If Not a.Value = a.Offset(i - a.Row, 0).Value Then
            Exit For
        End If
    Next
    If i > a.Row + 1 Then
        Range(a, a.Offset(i - a.Row)).Merge
    End If
Next a
Application.DisplayAlerts = True

hope it helps

**12588sam** · 05-05-2011, 11:47 AM

Thanks for this, I think we are nearly there - just one slight problem. The code does leave me with the following:

Column 1 Column 2
Row 1 A A
Row 2 A B
Row 3 A C
Row 4 A A
Row 5 B B

Where the first four A's in column 1 are one merged cell. Essentially the only error is in row 4 / column 1 - this should show the value B (with row 4/5 merged) and then the values A/B in column 2, rows 4/5.

Hope that makes sense?

**mohd9876** · 05-08-2011, 02:06 AM

If i understand you correctly please try this small modification in line 11:

Range(a, a.Offset(i - a.Row-1)).Merge

**Krishnakumar** · 05-08-2011, 02:47 AM

Hi,

Try this

Sub kTest()
    
    Dim r As Range, i As Long
    
    Set r = Intersect(ActiveSheet.UsedRange, Columns(1))
    
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    For i = r.Rows.Count - 1 To 1 Step -1
        If r.Cells(i, 1) = r.Cells(i + 1, 1) Then
            r.Cells(i, 1).Resize(2).Merge
        End If
    Next
    With Application
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With

End Sub

HTH