Count categorical data per person, from Different departments

[andrewcz]

Hi All,

I hope your all well.

I have a problem where i have names in a number of spreadsheets. each speadsheet is a different department. I am looking for a macro that does the following:
* loops through all sheets- In each sheet there is a name of an agent in a column and another column in the sheet that has a 'O' or an 'R' next to the name with a description. the O or R is in one column and the description is in another column,

• I need the macro to count the number of O and R per person.
• I then need it to copy into a seperate sheet with the count of the R and O per person. as well as possibly the department.
• so the final output is name of the person and the number of the 'O' and the name of person numbers of 'R'. with the department they belong to.

I have only just started with VBA so this is very advanced for me.
excelvba

 

[tonyyy]

You might consider the code below...

Assumptions:
1. Names are in Column A of each sheet;
2. O and R are in Column B of each sheet;
3. The sheet name is the department name;
4. There are headers in Row 1.

Sub LoopSheets()
Dim ws As Worksheet, wsSum As Worksheet
Dim rowz As Long, LastRow As Long, LastColumn As Long
Dim arr1 As Variant 'worksheet
Dim arr2 As Variant 'unique names
Dim arr3 As Variant 'summary
Dim i As Long, j As Long, k As Long

Application.ScreenUpdating = False
rowz = 0
For Each ws In ThisWorkbook.Sheets
    rowz = rowz + ws.UsedRange.Rows.Count
Next ws

ReDim arr3(1 To rowz, 1 To 4)
arr3(1, 1) = "Name"
arr3(1, 2) = "O"
arr3(1, 3) = "R"
arr3(1, 4) = "Department"
k = 2

For Each ws In ThisWorkbook.Sheets
    arr1 = ws.UsedRange
    LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    ws.Range("A2:A" & LastRow).Copy Destination:=ws.Cells(1, LastColumn + 1)
    ws.Range(ws.Cells(1, LastColumn + 1), ws.Cells(LastRow, LastColumn + 1)).RemoveDuplicates Columns:=1, Header:=xlNo
    LastRow = ws.Cells(ws.Rows.Count, LastColumn + 1).End(xlUp).Row
    arr2 = ws.Range(ws.Cells(1, LastColumn + 1), ws.Cells(LastRow, LastColumn + 1))
    ws.Columns(LastColumn + 1).EntireColumn.Delete
   
    For i = 1 To UBound(arr2)
        For j = 1 To UBound(arr1)
            If arr1(j, 1) = arr2(i, 1) Then 'match name
                arr3(k, 1) = arr2(i, 1)
                arr3(k, 4) = ws.Name
                If arr1(j, 2) = "O" Then
                    arr3(k, 2) = arr3(k, 2) + 1
                ElseIf arr1(j, 2) = "R" Then
                    arr3(k, 3) = arr3(k, 3) + 1
                End If
            End If
        Next j
        k = k + 1
    Next i
Next ws

Set wsSum = Sheets.Add(After:=Sheets(Sheets.Count))
wsSum.Range(wsSum.Cells(1, 1), wsSum.Cells(rowz, 4)).Value = arr3
Application.ScreenUpdating = True
End Sub

Cheers,

Tony

 

[andrewcz]

Thank you that works