Condensing Excel data with overlapping index/repet

Question

I have an excel sheet that is formatted like so:

I would like to format it to be something like this:

It is about 40,000 cells of information, so is there any way to do this that isn't manually?

Answer 1

I am by no means an excel expert, and this is going to be my first answer ever. Take this into account please.

I've checked it and it works. I've add a command button in Sheet1 (where the original data is), and when clicked this code writes formatted data into Sheet2.

No need to manually remove duplicates!

Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim MyArray() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer

Private Sub CommandButton1_Click()

'Get unique indexes
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Cells(Rows.Count, 1).End(xlUp).Row 'number of rows
cU1 = Range("A2:A" & lrU) 'Assuming your data starts in A2
For iU1 = 1 To UBound(cU1, 1)
   dU1(cU1(iU1, 1)) = 1
Next iU1

'Now dU1 contains indexes as unique values (about, absence, etc.)

For i = 0 To dU1.Count - 1 'for each index
    ReDim MyArray(1 To 1) As Variant 'starts a "new" array

    For j = 2 To 9 'each of the columns with values (D1-D8)
        a = 0
        For k = 2 To lrU 'all rows
            If (Worksheets("Sheet1").Cells(k, 1).Value = dU1.keys()(i) And Worksheets("Sheet1").Cells(k, j).Value <> "") Then
                    MyArray(UBound(MyArray)) = Worksheets("Sheet1").Cells(k, j).Value 'add value to array
                    ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
                    a = a + 1
            End If
        Next
        If a = 0 Then 'if no value found, add an element to array anyway
                    MyArray(UBound(MyArray)) = "" 'add value to array
                    ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
        End If
    Next
    Worksheets("Sheet2").Cells(i + 2, 1) = dU1.keys()(i) 'write indexes in another sheet

    For h = 2 To UBound(MyArray)
            Worksheets("Sheet2").Cells(i + 2, h) = MyArray(h - 1)
    Next
Next
End Sub

Answer 2

You could probably use =SUMIF to achieve this, since you appear to have numbers as values. Create a new sheet, copy column A from your data sheet to your new sheet and remove duplicates. Copy row 1 from your data sheet to your new sheet. Use this formula in sheet 2 cell B2:

=SUMIF(Sheet1!$A:$A;Sheet2!$A2;Sheet1!B:B)

Drag the formula to the right, then down.