CODEWITHSUNDEEP
excelvba
Indusha Sembakutti
Indusha Sembakutti

Reputation: 133

How to get the sum of two adjacent columns into one merged cell (VBA)?

I am creating a summary macro and I need to add up all the values of column C and D into the merged cell in E. In the image attached the sums are already placed to show the result I want. I already have code to merge the cells in column E based on the names in A. IE Sum up all overdue and critical for bob and place in merged column, then nick. Here is what I have I just need help getting the sum:

enter image description here

Sub MergeSameCell()

    Dim Rng As Range, xCell As Range
    Dim xRows As Integer

    Set WorkRng = ThisWorkbook.Worksheets("Summary").Range("A:A")

    lastRow = ActiveSheet.Columns("A").Cells.Find("*", SearchOrder:=xlByRows,
    LookIn:=xlValues, SearchDirection:=xlPrevious).Row

    xRows = lastRow
    For Each Rng In WorkRng.Columns
        For i = 1 To xRows - 1

            For j = i + 1 To xRows
                If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                    Exit For
                End If
            Next
            WorkRng.Parent.Range(Rng.Cells(i, 5), Rng.Cells(j - 1, 5)).Merge
            i = j - 1
        Next
    Next

End Sub

Upvotes: 1

Views: 743

Answers (3)

Scott Craner
Scott Craner

Reputation: 152605

This removes a couple of loops:

Sub MergeSameCell()

    With ThisWorkbook.Worksheets("Summary")
        Dim i as Long
        For i = 2 To .Rows.Count
            If .Cells(i, 1) = "" Then Exit Sub
            Dim x As Long
            x = .Evaluate("MATCH(TRUE," & .Cells(i, 1).Address & "<>" & .Range(.Cells(i, 1), .Cells(.Rows.Count, 1)).Address & ",0) - 2 + " & i)
            .Cells(i, 5).Value = Application.Sum(.Range(.Cells(i, 3), .Cells(x, 4)))
            .Range(.Cells(i, 5), .Cells(x, 5)).Merge
            i = x
        Next i
    End With

End Sub

Upvotes: 1

user4039065
user4039065

Reputation:

I will leave the alignment formatting of the merged cells to you.

Option Explicit

Sub MergeSameCell()

    Dim clientRng As Range
    Dim lastRow As Long, lastClientRow As Long

    With ThisWorkbook.Worksheets("Summary")

        .Columns(5).UnMerge

        Set clientRng = .Range("A2")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Do
            lastClientRow = .Columns(1).Find(what:=clientRng.Value, after:=clientRng, _
                                             lookat:=xlWhole, SearchDirection:=xlPrevious).Row
            With clientRng.Offset(0, 4)
                .Resize(lastClientRow - clientRng.Row + 1, 1).Merge
                .Formula = "=sumifs(c:c, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")+" & _
                            "sumifs(d:d, a:a, " & Chr(34) & clientRng.Value2 & Chr(34) & ")"
                'optionally revert the formulas to their returned value
                'value = .value2
            End With

            Set clientRng = clientRng.Offset(lastClientRow - clientRng.Row + 1, 0)

        Loop While clientRng.Row <= lastRow

    End With

End Sub

Upvotes: 1

pondersome
pondersome

Reputation: 183

The below uses your enclosed data specifically and assumes the data has already been sorted by column A and the cells in column E are already merged.

Public Sub GroupSum()
Dim i0 As Long, i1 As Long, strName As String
With ActiveSheet
    For i0 = 2 To .UsedRange.Rows.Count
        If Not .Cells(i0, 1).Value = strName Then
            strName = .Cells(i0, 1)
            i1 = i0
        End If
        .Cells(i1, 5).Value = .Cells(i0, 3).Value + .Cells(i0, 4).Value + .Cells(i1, 5).Value
    Next i0
End With
End Sub

Upvotes: 2

Related Questions