none
Adding data from multiple columns when headers are the same in Excel RRS feed

  • Question

  • I am working with a large data set and I need to combine data from multiple columns.  Each column has a header that is the name of a species, and the rest of the column is how many times that species was counted in each of several plots.  The issue is that many species were counted several times, so the same species has several columns, and I must combine the data that exists in each column so that it is found in only one column--sort of collapse all of the data into one for analyses.  I started by using =SUM(each cell) and filling down, but this situation occurs hundreds of times, so I would really love to learn a way that I can just make Excel add the values together if the header is the same.

    Eg of current data set up:

            Species1   Species1    Species1   Species 1   Species 2  Species 3 Species 3 Species 3

    Plot1     0           2                1                14             3              2               27         6

    Plot2      4            6               2               1                1               4                0          0

    Plot3      0          12                4              2                 0             0               8            8

    desired setup:

               Species1          Species2          Species3

    Plot 1       17                  3                      35

    Plot 2         13                1                       4

    Plot 3         18                 0                     16

    Tuesday, September 6, 2016 12:04 AM

All replies

  • Hi Libste,

    We are doing the research about your problem. There might be some delay about the response. Appreciate your patience.
    Tuesday, September 6, 2016 9:19 AM
  • The below will help you.  In future if you add species4 then add that to summary table also.

    Assumed your first table is at A10:I13. and summary table at A15:D18. Then in B16 paste below formula.

    =SUMIFS($B11:$I11,$B$10:$I$10,B$15)

    Then copy B16 to B16:D18.


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.

    Thursday, September 8, 2016 5:27 AM
    Answerer
  • Hi Libste,

    According to your description, you could refer to code like below:

    Sub Demo()
    
       Dim Arr() As Variant
       Arr = DistinctValues(Range("B1:H1"), False)
       
       Dim targetRng As Range
       Set targetRng = Range("B1:H4")
       
       Dim rowNum As Integer
       rowNum = targetRng.Rows.Count
       
       Dim Destination As Range
       Set Destination = Range("K1")
       Set Destination = Destination.Resize(rowNum, UBound(Arr))
       
       For f = 1 To UBound(Arr)
           Destination(1, f).Value = CStr(Arr(f))
       Next f
       
       Dim startAddress As String
       
       Dim lastCell As Range
       For i = 2 To targetRng.Rows.Count
           startAddress = targetRng.Rows(i).Cells(1).Address
           For j = 1 To UBound(Arr)
           
              Set lastCell = FindLastCell(CStr(Arr(j))).Offset(i - 1, 0)
              Destination(i, j).Value = WorksheetFunction.Sum(Range(startAddress & ":" & lastCell.Address))
              startAddress = lastCell.Offset(0, 1).Address
              
           Next
       Next i
       
    End Sub
    
    Function FindLastCell(ByRef condition As String) As Range
        Set Rng = Range("B1:H1")
     
            lrw = Rng.Find(What:=condition, _
                           After:=Rng.Cells(1), _
                           LookAt:=xlPart, _
                           LookIn:=xlFormulas, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, _
                           MatchCase:=False).Row
           
            lcol = Rng.Find(What:=condition, _
                            After:=Rng.Cells(1), _
                            LookAt:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
           
        Set FindLastCell = Rng.Parent.Cells(lrw, lcol)
    End Function
    Function DistinctValues(InputValues As Variant, _
        Optional IgnoreCase As Boolean = False) As Variant
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' DistinctValues
    ' This function accepts a set of values in InputValues and returns an Array
    ' containing the distinct items in that input set. The order of elements in the result
    ' array is the same as in the InputValues. InputValues may be either a Range object
    ' or an Array. In either case, it must be one-dimensional (in the case of a Range,
    ' it may be either a row or column range). If InputValues has more than one dimension,
    ' the function returns a #REF error. The IgnoreCase parameter indicates whether to do
    ' a case-sensitive or case-insensitive comparison when comparing text values. If TRUE,
    ' case is ignored and 'abc' is treated the same as 'ABC'. If FALSE, case is taken into
    ' account and 'abc' is treated differently than 'ABC'.
    '
    ' If the function is called from a worksheet, it must be array entered (CTRL SHIFT ENTER)
    ' into the array of cells that will receive the resutling Distinct values. The size of
    ' the returned array will be the same size as the array into which the function was
    ' entered. The Distinct values will fill the first N cells and the remaining array entries
    ' will be vbNullStrings. The result is properly transposed (or not) depending on whether
    ' it was called from a row-range or a column-range of cells on the worksheet.
    ' The result array is always sized to match the size of the range into which it was
    ' entered, even if that array contains more entries than the InputValues range. This behavior
    ' differs from the standard behavior of Excel's own array functions.
    '
    ' If the function is called by another VBA procedure, not from worksheet cells, the
    ' array is a single dimensional array with only enough elements to contain the Distinct
    ' elements. The LBound of the array is 1. The variable that receives the array of distinct
    ' values should be declared as a Variant:
    '   Dim Res As Variant
    '   Res = DistinctElements(MyArray,True)
    '
    ' Empty elements, those with a value of vbNullString or Empty, are not compared. Thus,
    ' vbNullString and Empty are not considered values in the own right and are not counted
    ' amongst the Distinct Values. NULL values are not allowed in the InputValues and the
    ' presence of a NULL value will cause an #NULL error, If there is an Object type variable
    ' in the InputValues other than a Range object, a #VALUE error will be returned.
    '
    ' String representations of numbers are considered the same as numbers, so 2 and "2"
    ' are not distict values.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim ResultArray() As Variant
    Dim UB As Long
    Dim TransposeAtEnd As Boolean
    Dim N As Long
    Dim ResultIndex As Long
    Dim M As Long
    Dim ElementFoundInResults As Boolean
    Dim NumCells As Long
    Dim ReturnSize As Long
    Dim Comp As VbCompareMethod
    Dim V As Variant
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Set the text comparison value to be used by StrComp based on
    ' the setting of IgnoreCase.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If IgnoreCase = True Then
        Comp = vbTextCompare
    Else
        Comp = vbBinaryCompare
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' This first large block of code determines whether the function
    ' is being called from a worksheet range or by another function.
    ' If it is being called from a worksheet, it must be called from
    ' a range with only one column or only one row. Two-dimensional
    ' ranges will cause a #REF error.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If IsObject(Application.Caller) = True Then
        If Application.Caller.Rows.Count > 1 And Application.Caller.Columns.Count > 1 Then
            DistinctValues = CVErr(xlErrRef)
            Exit Function
        End If
        ''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Save the size of the region from which the
        ' function was called and save a flag indicating
        ' whether we need to transpose the result upon
        ' returning.
        ''''''''''''''''''''''''''''''''''''''''''''''''''
        If Application.Caller.Rows.Count > 1 Then
            TransposeAtEnd = True
            ReturnSize = Application.Caller.Rows.Count
        Else
            TransposeAtEnd = False
            ReturnSize = Application.Caller.Columns.Count
        End If
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Were we passed a Range object or a VBA array?
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If IsObject(InputValues) = True Then
        If TypeOf InputValues Is Excel.Range Then
            ''''''''''''''''''''''''''''''''''''''''''''''''
            ' Input is a Range object.
            ''''''''''''''''''''''''''''''''''''''''''''''''
            If InputValues.Rows.Count > 1 And InputValues.Columns.Count > 1 Then
                DistinctValues = CVErr(xlErrRef)
                Exit Function
            End If
            If InputValues.Rows.Count > 1 Then
                NumCells = InputValues.Rows.Count
            Else
                NumCells = InputValues.Columns.Count
            End If
            UB = NumCells
        Else
            DistinctValues = CVErr(xlErrRef)
            Exit Function
        End If
    Else
        '''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' InputValues is not a Range object.
        '''''''''''''''''''''''''''''''''''''''''''''''''''''
        If IsArray(InputValues) = True Then
            Select Case NumberOfArrayDimensions(InputValues)
                Case 0
                    ''''''''''''''''''''''''''''''''''''
                    ' Zero dimensional array (scalar).
                    ' Return an array of 1 element with
                    ' that value.
                    ''''''''''''''''''''''''''''''''''''
                    ReDim ResultArray(1 To 1)
                    ResultArray(1) = InputValues
                    DistinctValues = ResultArray
                    Exit Function
                Case 1
                    UB = UBound(InputValues) - LBound(InputValues) + 1
                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    ' If we were passed in an array from a worksheet
                    ' function (e.g., =DISTINCTVALUES({1,2,3}), we
                    ' need to set NumCells to the size of the input array.
                    ' This is used later to properly resize the result array.
                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    If IsObject(InputValues) = False Then
                        NumCells = UB
                    End If
                Case Else
                    DistinctValues = CVErr(xlErrValue)
                    Exit Function
            End Select
        Else
            ReDim ResultArray(1 To 1)
            ResultArray(1) = InputValues
            DistinctValues = ResultArray
            Exit Function
        End If
    End If
           
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Ensure we don't have any NULLs or Objects in the InputValues.
    ' A Range object is allowed.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For Each V In InputValues
        If IsNull(V) = True Then
            DistinctValues = CVErr(xlErrNull)
            Exit Function
        End If
        If IsObject(V) = True Then
            If Not TypeOf V Is Excel.Range Then
                DistinctValues = CVErr(xlErrValue)
                Exit Function
            End If
        End If
    Next V
           
    ''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Allocate the ResultArray and fill it with either
    ' vbNullStrings if we were called from a worksheet
    ' or with Empty values if called by a VB procedure.
    '''''''''''''''''''''''''''''''''''''''''''''''''''
    ReDim ResultArray(1 To UB)
    For N = LBound(ResultArray) To UBound(ResultArray)
        If IsObject(Application.Caller) = True Then
            ResultArray(N) = vbNullString
        Else
            ResultArray(N) = Empty
        End If
    Next N
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' This is the logic that actually tests for duplicate values.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ResultIndex = 1
    ''''''''''''''''''''''''''''''''''''
    ' We can always assume that the
    ' first element in the InputValues
    ' will be distinct so far.
    ''''''''''''''''''''''''''''''''''''
    ResultArray(1) = InputValues(1)
    ''''''''''''''''''''''''''''''''''''''''
    ' Loop throught the entire InputValues
    ' array.
    ''''''''''''''''''''''''''''''''''''''''
    For N = 2 To UB
        '''''''''''''''''''''''''''''''''
        ' Set our Found flag = False. This
        ' flag is used to indicate whether
        ' we find Input(N) in the list of
        ' distinct elements. If we found it
        ' earlier, it is no longer a distinct
        ' element and we won't put it in the
        ' ResultArray.
        ''''''''''''''''''''''''''''''''''''
        ElementFoundInResults = False
        For M = 1 To N
            '''''''''''''''''''''''''''''''''''''
            ' Scan through the array ResultArray
            ' looking for Input(N). If we find it,
            ' Input(N) is a duplicate so set the
            ' Found flag to True.
            '''''''''''''''''''''''''''''''''''''
            If StrComp(CStr(ResultArray(M)), CStr(InputValues(N)), Comp) = 0 Then
                ElementFoundInResults = True
                Exit For
            End If
        Next M
        ''''''''''''''''''''''''''''''''''''''''''''
        ' If we didn't find Input(N) in ResultArray
        ' then Input(N) is distinct so we increment
        ' ResultIndexand add Input(N) to ResultArray.
        ''''''''''''''''''''''''''''''''''''''''''''
        If ElementFoundInResults = False Then
            ResultIndex = ResultIndex + 1
            ResultArray(ResultIndex) = InputValues(N)
        End If
    Next N
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Here, we resize the ResultArray to the appropriate number of
    ' elements. ResultIndex is equal to the number of distinct elements found.
    ' If the function was called from a worksheet, ReturnSize is
    ' positive, equal to the number of cells in the array into which
    ' the function was entered and NumCells is the number of cells in
    ' the InputRange. If the function was called by another VB function,
    ' not from a worksheet, ReturnSizse and NumCells will be 0. Thus,
    ' if ReturnSize is not 0 and ResultIndex, the number of distinct elements,
    ' is less than the number of cells from in the InputValues, we
    ' set ResultIndex to the number of cells from which the function was called.
    ' This allows us in the For N loop that follows to pad out the
    ' entire Application.Caller range with vbNullStrings to prevent
    ' #N/A errors if the function is called from a range with more cells
    ' than there were disticnt elements. Note that this behavior differs
    ' from Excel's normal array formula handling.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If ReturnSize <> 0 Then
        If ResultIndex < NumCells Then
            If ResultIndex < ReturnSize Then
                ResultIndex = ReturnSize
            End If
        End If
    End If
    
    ReDim Preserve ResultArray(1 To ResultIndex)
    If UBound(ResultArray) > NumCells Then
        For N = NumCells + 1 To ReturnSize
            ResultArray(N) = vbNullString
        Next N
    End If
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' If we were called from a Column range on a worksheet (Rows.Count > 1),
    ' we need to transform ResultArray into a 2-dimensional array and transpose
    ' it so it will be properly stored in the column. Transpose1DArray does this
    ' function. If the function was not called from a worksheet, then the
    ' TransposeAtEnd flag will be false and we just return the array.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If TransposeAtEnd = True Then
        DistinctValues = Transpose1DArray(Arr:=ResultArray, ToRow:=False)
    Else
        DistinctValues = ResultArray
    End If
    
    End Function
    
    
    Function TransposeArray(Arr As Variant) As Variant
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' TransposeArray
    ' This function tranposes the array Arr. Arr must be
    ' a two dimensional array. If Arr is not an array, the
    ' result is just Arr itself. If Arr is a 1-dimensional
    ' array, the result is just Arr itself. If you need to
    ' transpose a 1-dimensional array from a row to a column
    ' in order to properly return it to a worksheet, use
    ' Transpose1DArray. If Arr has more than three dimensions,
    ' an error value is returned.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim R1 As Long
    Dim R2 As Long
    Dim C1 As Long
    Dim C2 As Long
    Dim LB1 As Long
    Dim LB2 As Long
    Dim UB1 As Long
    Dim UB2 As Long
    
    Dim Res() As Variant
    Dim NumDims As Long
    
    If IsArray(Arr) = False Then
        TransposeArray = Arr
        Exit Function
    End If
    
    NumDims = NumberOfArrayDimensions(Arr)
    Select Case NumDims
        Case 0
            If IsObject(Arr) = True Then
                Set TransposeArray = Arr
            Else
                TransposeArray = Arr
            End If
        Case 1
            TransposeArray = Arr
        Case 2
            LB1 = LBound(Arr, 1)
            UB1 = UBound(Arr, 1)
            LB2 = LBound(Arr, 2)
            UB2 = UBound(Arr, 2)
            R2 = LB1
            C2 = LB2
            ReDim Res(LB2 To UB2, LB1 To UB1)
            For R1 = LB1 To UB1
                For C1 = LB2 To UB2
                    Res(C1, R1) = Arr(R1, C1)
                    C2 = C2 + 1
                Next C1
            R2 = R2 + 1
            Next R1
            TransposeArray = Res
        Case Else
            TransposeArray = CVErr(9)
    End Select
    
    End Function
    
    Function NumberOfArrayDimensions(Arr As Variant) As Long
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' NumberOfArrayDimensions
    ' This returns the number of dimensions of the array
    ' Arr. If Arr is not an array, the result is 0.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim LB As Long
    Dim N As Long
    
    On Error Resume Next
    N = 1
    Do Until Err.Number <> 0
        LB = LBound(Arr, N)
        N = N + 1
    Loop
    NumberOfArrayDimensions = N - 2
    
    End Function
    
    Function Transpose1DArray(Arr As Variant, ToRow As Boolean) As Variant
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Transpose1DArray
    ' This function transforms a 1-dim array to a 2-dim array and
    ' transposes it. This is required when returning arrays back to
    ' worksheet cells. The ToRow parameter determines if the array is
    ' to be returned to the worksheet as a row (TRUE) or as a columns (FALSE).
    ' This should only be used for 1-dim arrays that are going back to
    ' a worksheet.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim Res As Variant
    Dim N As Long
    
    If IsArray(Arr) = False Then
        Transpose1DArray = CVErr(xlErrValue)
        Exit Function
    End If
    If NumberOfArrayDimensions(Arr) <> 1 Then
        Transpose1DArray = CVErr(xlErrValue)
        Exit Function
    End If
    
    If ToRow = True Then
        ReDim Res(LBound(Arr) To LBound(Arr), LBound(Arr) To UBound(Arr))
        For N = LBound(Res, 2) To UBound(Res, 2)
            Res(LBound(Res), N) = Arr(N)
        Next N
    Else
        ReDim Res(LBound(Arr) To UBound(Arr), LBound(Arr) To LBound(Arr))
        For N = LBound(Res, 1) To UBound(Res, 1)
            Res(N, LBound(Res)) = Arr(N)
        Next N
    End If
    Transpose1DArray = Res
    
    End Function

    The result:

    For more information, please refer to links below:

    http://www.cpearson.com/excel/ArraysAndRanges.aspx

    http://www.cpearson.com/excel/distinctvalues.aspx

    http://www.rondebruin.nl/win/s9/win005.htm

    Disclaimer: This response contains a reference to a third party World Wide Web site. Microsoft is providing this information as a convenience to you. Microsoft does not control these sites and has not tested any software or information found on these sites; therefore, Microsoft cannot make any representations regarding the quality, safety, or suitability of any software or information found there. There are inherent dangers in the use of any software found on the Internet, and Microsoft cautions you to make sure that you completely understand the risk before retrieving any software from the Internet.

    Thanks for your understanding.
    Tuesday, October 18, 2016 7:47 AM