Consulting

Results 1 to 6 of 6

Thread: Excel vba merge cells based on duplicate cell data

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #6
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,970
    Merged cells are a big pain with vba.
    I can't arrange for the middle cell of 3 merged cells to contain the value (as in your picture), Excel only allows the top left cell of a merged range to contain the value.
    In the macro below, I've arranged for the 4 rightmost columns to be merged in the same way as the first column, and each merged area will take on the value of the top cell in that area, losing any values that are different in the other cells (if they're all the same, consider removing duplicate rows instead; it's built in and faster).
    There should be no merged cells before you start.
    There are entire lines of code commented out which I used as debug lines which can be deleted.
    According to your picture the data body seems to start in row 3, hence the line rw = 3 'start row in the code.
    Sub blah()
        lr = Cells(Rows.Count, "M").End(xlUp).Row
        rw = 3    'start row
        Set myRng = Range(Cells(rw, "M"), Cells(lr, "M"))
        ' myRng.Select
        Set TopCell = myRng.Cells(1)
        Set BottomCell = myRng.Cells(1)
        myVal = TopCell.Value
        For Each cll In myRng.Cells
            If cll.Value = myVal Then
                Set BottomCell = cll
            Else
            Range(TopCell, BottomCell).Select
            If TopCell.Row <> BottomCell.Row Then
                ' merge:
               For ofst = 4 To 0 Step -1
                    ' Range(TopCell, BottomCell).Offset(, ofst).Select
                    Merge Range(TopCell, BottomCell).Offset(, ofst)
                Next ofst
            End If
            ' cll.Select
            Set TopCell = cll
            myVal = TopCell.Value
            Set BottomCell = cll
            End If
        Next cll
        Range(TopCell, BottomCell).Select
        If TopCell.Row <> BottomCell.Row Then
            ' merge
            For ofst = 4 To 0 Step -1
                ' Range(TopCell, BottomCell).Offset(, ofst).Select
                Merge Range(TopCell, BottomCell).Offset(, ofst)
            Next ofst
        End If
    End Sub
    
    Sub Merge(Rng)
        ' Rng.Select
        With Rng
            .VerticalAlignment = xlCenter
            Application.DisplayAlerts = False
            .MergeCells = True
            Application.DisplayAlerts = True
        End With
    End Sub
    Last edited by Aussiebear; 01-18-2025 at 03:13 PM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •