Merge of cells

[vmjan02]

I have data like this

Fixed FTTH CBU Tech Compliants V1.xlsm
	B	C	D
24	Node*+	Root Cause	Ticket Number+
25	218-00_SAFAKH00OL0	Access-Uplink issue	PR00035914963|PR00035915931
26		Dark Fiber	PR00035913520|PR00035914983|PR00035916061|PR00035917254|PR00035920093
27		MDT	PR00035931421|PR00035931520|PR00035933798|PR00035933799|PR00035933811
28	116-42_NFELRDAAOLK	Man Made	PR00035951924
29	111-00_HTYNRD00OL5	MDT	PR00035909693|PR00035923231
30		Trans Media	PR00035963757
31	116-42_NFELRDAAOT1	Trans Media	PR00035967382
OLT2

and looking for this output using VBA, but no luck till now any idea, as merge of cells in column B will be dynamic depending on column C

output

Fixed FTTH CBU Tech Compliants V1.xlsm
	B	C	D
24	Node*+	Root Cause	Ticket Number+
25	218-00_SAFAKH00OL0	Access-Uplink issue	PR00035914963|PR00035915931
26		Dark Fiber	PR00035913520|PR00035914983|PR00035916061|PR00035917254|PR00035920093
27		MDT	PR00035931421|PR00035931520|PR00035933798|PR00035933799|PR00035933811
28	116-42_NFELRDAAOLK	Man Made	PR00035951924
29	111-00_HTYNRD00OL5	MDT	PR00035909693|PR00035923231
30		Trans Media	PR00035963757
31	116-42_NFELRDAAOT1	Trans Media	PR00035967382
OLT2

 

[vmjan02]

I tried this code but still no luck,

Sub MergeCellsBasedOnCriteria()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("OLT2") ' Change "Sheet1" to the name of your sheet

    Dim startCell As Range
    Dim endCell As Range
    Dim currentRow As Long
    Dim lastRow As Long
    
    ' Initialize variables
    currentRow = 25
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' Loop through rows starting from B25
    Do While currentRow <= lastRow
        ' Check if the current cell in column B is not blank
        If ws.Cells(currentRow, "B").Value <> "" Then
            ' Set startCell if it's not already set (i.e., start of a new range)
            If startCell Is Nothing Then
                Set startCell = ws.Cells(currentRow, "B")
            End If
        Else
            ' Check if startCell is set and if the corresponding cell in column C is not empty
            If Not startCell Is Nothing And ws.Cells(currentRow, "C").Value <> "" Then
                ' Set endCell
                Set endCell = ws.Cells(currentRow - 1, "B")
                ' Merge the cells from startCell to endCell
                ws.Range(startCell, endCell).Merge
                ' Reset startCell and endCell for the next range
                Set startCell = Nothing
                Set endCell = Nothing
            End If
        End If
        currentRow = currentRow + 1
    Loop
End Sub

 

[mumps]

Try:

Sub MergeCells()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long, i As Long, rng As Range
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = lRow To 26 Step -1
        If Cells(x - 1, 1) <> "" Then
            Range("A" & x - 1).EntireRow.Insert
        End If
    Next x
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.DisplayAlerts = False
    For Each rng In Range("B26:B" & lRow).SpecialCells(xlCellTypeConstants).Areas
        rng.Offset(, -1).Merge
    Next
    Application.DisplayAlerts = True
    Range("B24:B" & lRow).SpecialCells(xlBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

@vmjan02 that is just a terrible idea. Once you do that if you then want to apply a filter, do a pivot or any other analysis you won't be able to.
Most of us avoid merged cells like the plague.

 

[vmjan02]

Try:

Sub MergeCells()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long, i As Long, rng As Range
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = lRow To 26 Step -1
        If Cells(x - 1, 1) <> "" Then
            Range("A" & x - 1).EntireRow.Insert
        End If
    Next x
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.DisplayAlerts = False
    For Each rng In Range("B26:B" & lRow).SpecialCells(xlCellTypeConstants).Areas
        rng.Offset(, -1).Merge
    Next
    Application.DisplayAlerts = True
    Range("B24:B" & lRow).SpecialCells(xlBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

the output is not as desired, it not the output i am looking for. I have shared the desired output on my first post.

 

[vmjan02]

@vmjan02 that is just a terrible idea. Once you do that if you then want to apply a filter, do a pivot or any other analysis you won't be able to.
Most of us avoid merged cells like the plague.

yes i do and well aware about it as well, but its the final stage and this output will be added to the ppt slide, so working out a dynamic merge cell. once this part of pasting the range ot PPT is over, then it will delete all the rows for the next working.

 

[mumps]

Looking into it.

 

[mumps]

This is the result when I ran the macro below:

Book1
	B	C	D
24	Node*+	Root Cause	Ticket Number+
25	218-00_SAFAKH00OL0	Access-Uplink issue	PR00035914963|PR00035915931
26		Dark Fiber	PR00035913520|PR00035914983|PR00035916061|PR00035917254|PR00035920093
27		MDT	PR00035931421|PR00035931520|PR00035933798|PR00035933799|PR00035933811
28	116-42_NFELRDAAOLK	Man Made	PR00035951924
29	111-00_HTYNRD00OL5	MDT	PR00035909693|PR00035923231
30		Trans Media	PR00035963757
31	116-42_NFELRDAAOT1	Trans Media	PR00035967382
Sheet4

It looks exactly the same as the second table in your original post.

Sub MergeCells()
    Application.ScreenUpdating = False
    Dim lRow As Long, x As Long, i As Long, rng As Range
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = lRow To 25 Step -1
        If Cells(x, 2) <> "" And Cells(x - 1, 3) <> "" Then
            Range("A" & x).EntireRow.Insert
        End If
    Next x
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.DisplayAlerts = False
    For Each rng In Range("C26:C" & lRow).SpecialCells(xlCellTypeConstants).Areas
        rng.Offset(, -1).Merge
    Next
    Application.DisplayAlerts = True
    Range("C24:C" & lRow).SpecialCells(xlBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

 

[vmjan02]

@mumps thanks a lot. this is perfect. thank you.

 

[mumps]

You are very welcome.