Count Results

Please see attach spreadsheet for example,

Can you please help me automate the counting of records using a macro.

There are three worksheets
1. Priorities - Lists all the Priorities in column A that will be used in responses on the Responses worksheet
2. Responses - Each row is a set of responses by a user and there may be up to 50 user responses.  I will populate these manually.  The worksheet has some examples.  The responses going across the row can go up to 150 after the name in column b.
3. Results - Counts the responses for every row by user that is in the responses worksheet. The responses are are totaled in the last column. (or on a separate worksheet if easier)

When you look at the attached file you can see two examples.
Who is Participating?
Máté FarkasDatabase Developer and AdministratorCommented:
You can do this with a simple way.
Check the attached file.
abbas abdullaCommented:
Why you don't use countif only
In cell B2 = COUNTIF(Responses!$2:$2,$A2)
In cell C2 =COUNTIF(Responses!$3:$3,$A2)
ShumsDistinguished Expert - 2017Commented:
If you are into VBA solution, then try below:
Sub UpdateResults()
Dim RespSh As Worksheet, PriotSh As Worksheet, TestSh As Worksheet, xWs As Worksheet
Dim RespLR As Long, PriotLR As Long, LRow As Long, LCol As Long, RowIndex As Long, ColIndex As Long

'Define Variables
Set RespSh = Worksheets("Responses")
Set PriotSh = Worksheets("Priorities")
RespLR = RespSh.Cells(Rows.Count, "B").End(xlUp).Row
PriotLR = PriotSh.Cells(Rows.Count, "A").End(xlUp).Row

'Disable Events
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With

'Delete Test Sheet
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Worksheets
    If xWs.Name = "Test" Then
    End If
Application.DisplayAlerts = True

'Create New Sheet
With ThisWorkbook
    Set TestSh = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
End With
TestSh.Name = "Test"

'Copy Unique Names
RespSh.Range("B1:B" & RespLR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=TestSh.Range("A1"), Unique:=True

'Copy Priorities
PriotSh.Range("A1:A" & PriotLR).Copy
TestSh.Range("B1").PasteSpecial xlPasteValues, Transpose:=True
Application.CutCopyMode = False

'Update Formula
LRow = TestSh.Cells(Rows.Count, "A").End(xlUp).Row
LCol = TestSh.Cells(1, Columns.Count).End(xlToLeft).Column
TestSh.Cells(1, LCol + 1).Value = "Total"
For RowIndex = 2 To LRow
    For ColIndex = 2 To LCol
        With TestSh.Cells(RowIndex, ColIndex)
            .FormulaR1C1 = "=SUMPRODUCT((NameList=RC1)*(DataList=R1C))"
        End With
        With TestSh.Cells(RowIndex, LCol + 1)
            .FormulaR1C1 = "=SUM(RC2:RC[-1])"
        End With
    Next ColIndex
Next RowIndex

'Enable Events
With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
End Sub

Open in new window

In Attached, just click Update Result, it will create a new sheet "Test" with required output.
Kindly Note: Before applying above macro into your original workbook, you need to create Two Named Range as below:

Open in new window

=OFFSET(Responses!$B$2, 0, 0, COUNT(IF(Responses!$B$2:$B$1000="", "", 1)), 1)

Open in new window

ShumsDistinguished Expert - 2017Commented:
WOW! Initially you asked for VBA solution, have you tried my solution?
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.