Excel Formula or VBA if necessary

[Claret]

Hello,

I have a table of data (shortened example below) with 40+ questions and 500 + respondents.

The green section of the table indicates the questions that were answered incorrectly by an individual and the number of times they answered the question incorrectly (these are quality checks so the same questions are checked multiple times)

I'd like to be able to consolidate the data (via either formula or simple code) so that for each person, just the incorrect questions and the number of times incorrect are shown (as per the example in the red section of the table). Effectively ignoring those where there are no errors and returning a horizontal list of errors in separate cells with no blanks.

Any help would be much appreciated.

David

Qu1

Qu2

Qu3

Qu4

Qu5

Qu6

Qu7

Qu8

Qu9

Qu10

Person 1

1

2

1

1

Qu1 (1)

Qu3 (2)

Qu5 (1)

Qu7 (1)

Person 2

1

2

1

1

Qu2 (1)

Qu6 (2)

Qu9 (1)

Qu10 (1)

Person 3

Person 4

1

Qu4 (1)

Person 5

1

3

1

Qu3 (1)

Qu5 (3)

Qu8 (1)

<tbody>
</tbody>

 

[Joe4]

Exactly what rows/columns are your data tables in?

 

[Joe4]

Assuming it starts up in cell A1, so the table goes out to column K, this VBA code will do what you want:

Sub MyMacro()

    Dim lastRow As Long
    Dim myRow As Long
    Dim myCol As Long
    Dim popCol As Long
    
    Application.ScreenUpdating = False
    
'   Find last row with data in column A
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Loop through all rows
    For myRow = 2 To lastRow
'       Set first column to populate
        popCol = 12
'       Loop through columns B-K
        For myCol = 2 To 11
'           If value is greater than zero, write to end of table
            If Cells(myRow, myCol) > 0 Then
                Cells(myRow, popCol) = Cells(1, myCol) & Chr(10) & "(" & Cells(myRow, myCol) & ")"
'               Increment popCol
                popCol = popCol + 1
            End If
        Next myCol
    Next myRow
    
    Application.ScreenUpdating = True
    
End Sub

 

[Claret]

Exactly what rows/columns are your data tables in?

B2 to BI600 although some are blank should there be more names added (column B) or more questions added (row 2)

 

[Claret]

Thanks very much, Joe4 - I'll give this a whirl

David

 

[Claret]

I've amended the code slightly (see below) because the brackets were appearing as (Q1 1) rather than Q1 (1). This is fine, but another minor issue is that the Q1 1 is now appearing in the cells with a line of white space ahead of it - is there a way to adapt the code to prevent this or alternatively can some trim code be added?

Thanks very much for your help with this - it's much appreciated.

David

 

[Claret]

Helps if I do add the code of course

Dim lastRow As Long
Dim myRow As Long
Dim myCol As Long
Dim popCol As Long


Application.ScreenUpdating = False

' Find last row with data in column A
lastRow = Cells(Rows.Count, "B").End(xlUp).Row

' Loop through all rows
For myRow = 3 To lastRow
' Set first column to populate
popCol = 63
' Loop through columns B-K
For myCol = 4 To 60
' If value is greater than zero, write to end of table
If Cells(myRow, myCol) > 0 Then
Cells(myRow, popCol) = Cells(1, myCol) & Chr(10) & Cells(myRow, myCol)
' Increment popCol
popCol = popCol + 1
End If
Next myCol
Next myRow

Application.ScreenUpdating = True

End Sub

 

[Joe4]

but another minor issue is that the Q1 1 is now appearing in the cells with a line of white space ahead of it

I am guessing that is because your headers in row 1 may have space before them.
If that is the case, add the TRIM function, i.e.

[COLOR=#333333]Cells(myRow, popCol) = Trim(Cells(1, myCol)) & Chr(10) & Cells(myRow, myCol)[/COLOR]

 

[Claret]

Thanks Joe4

I've amended the code but still have the same issue - the headers are actually in row 2 in row and not row 1. Is this something I've neglected to amend in the code? Sorry - not particularly VBA literate as you'll no doubt have gathered.

David

Dim lastRow As Long
Dim myRow As Long
Dim myCol As Long
Dim popCol As Long


Application.ScreenUpdating = False

' Find last row with data in column A
lastRow = Cells(Rows.Count, "B").End(xlUp).Row

' Loop through all rows
For myRow = 3 To lastRow
' Set first column to populate
popCol = 63
' Loop through columns B-K
For myCol = 4 To 60
' If value is greater than zero, write to end of table
If Cells(myRow, myCol) > 0 Then
Cells(myRow, popCol) = Trim(Cells(1, myCol)) & Chr(10) & Cells(myRow, myCol)
' Increment popCol
popCol = popCol + 1
End If
Next myCol
Next myRow

Application.ScreenUpdating = True

End Sub

 

[Joe4]

Yes, if the headers are in row 2, you need to amend this line:

[COLOR=#333333]Cells(myRow, popCol) = Trim(Cells([/COLOR][COLOR=#ff0000][B]2[/B][/COLOR][COLOR=#333333], myCol)) & Chr(10) & Cells(myRow, myCol)[/COLOR]