asked on

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.
CountResults.xlsx

abbas abdulla

Hi,
Why you don't use countif only
In cell B2 = COUNTIF(Responses!$2:$2,$A2)
In cell C2 =COUNTIF(Responses!$3:$3,$A2)

ASKER CERTIFIED SOLUTION

Máté Farkas

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Shums Faruk

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
        xWs.Delete
    End If
Next
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
TestSh.Activate
TestSh.Range("A1").Select

'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:
DataList:

=OFFSET(Responses!$C$2,0,0,COUNTA(Responses!$C:$C),COUNTA(Responses!$2:$2))

Open in new window

NameList:

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

Open in new window

CountResults_v1.xlsm

Shums Faruk

WOW! Initially you asked for VBA solution, have you tried my solution?