Macro to add cell values together RRS feed

  • Question

  • Hey

    I have a range of data that is split with the measure being 1,2,3,4..etc and the person being a,b,c...etc. the position of the value is split into Red, amber or green (with a - in the blank cell(s) and dependant on target 1 or all of the RAG could be displayed.

    I need to combine the data (just adding them together)so that for each measure I only have 1 line. table 1 is the raw data and table 2 is how I need it to look.

    I tried to write a macro adding a line below and doing an =sum() then paste values and delete the red amber green but as sometimes I could have red amber and green and others just red for example it didn't work.

    Table 1

    Table 2

    Thanks in advance.

    Wednesday, August 9, 2017 1:05 PM

All replies

  • Table 1

    Table 2

    Wednesday, August 9, 2017 1:08 PM
  • Hi dude_sweet7,

    Please try below code.

    Sub AddCellsTogether()

    Dim sht1  As Worksheet

    Dim sht2 As Worksheet

    Dim idx As Integer

    Set sht1 = Worksheets("Sheet1")

    Set sht2 = Worksheets.Add

    lastRow1 = sht1.Cells(sht1.Rows.Count, 1).End(xlUp).Row

    lastRow2 = sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Row

    lastCol = sht1.Cells(1, sht1.Columns.Count).End(xlToLeft).Column

    Application.ScreenUpdating = False

    sht1.Rows(1).Copy sht2.Rows(1)

    For i = 2 To lastRow1

    ID = sht1.Cells(i, 1)

    On Error Resume Next

    idx = WorksheetFunction.Match(ID, sht2.Range("A1:A" & lastRow2), 0)

    If idx = 0 Then

             lastRow2 = lastRow2 + 1

             sht1.Rows(i).Copy sht2.Rows(lastRow2)

             sht2.Rows(lastRow2).Cells(1, 3) = "Total"

    ElseIf idx > 1 Then

             For j = 5 To lastCol

             sourcevalue = sht1.Cells(i, j)

             targetvalue = sht2.Cells(idx, j)

                 If IsNumeric(sourcevalue) Then

                      If IsNumeric(targetvalue) Then

                       sht2.Cells(idx, j) = targetvalue + sourcevalue


                      sht2.Cells(idx, j) = sourcevalue

                     End If

                 End If

               Next j

    End If

    idx = 0

    Next i

    Application.ScreenUpdating = True

    End Sub

    Thursday, August 10, 2017 11:06 AM
  • There is no need for a macro, you can use DATA\Subtotal or a Pivottable, see screen shots below.


    Thursday, August 10, 2017 1:56 PM