Tally data in Rows into Columns based on values - NOT simply transposing

Question

I have a list of Task Entries by Row as: Date, Employee, Task and Hours. Each employee may have multiple tasks each day. I want to summarize all of the tasks for each employee for each day as well as the total number of hours for a more complex analysis later. There is sample data below - Sheet 1 with the output from my very basic code - Sheet 2. Sample Data

However, I need to process ~10,000 entries/yr to summarize ~30 Tasks that have been performed by ~30 people... I have no idea how to use a matrix to do so without writing out an individual "If Task = TaskA then..." statement for all 30 tasks, which would be painfully slow. Ideally, I would be able to automatically take all of the data in the Task column, remove all of the duplicates and then use that single-column array to name the columns and match the value for each Task with the appropriate column in order to classify them...

Sub Tasks()
    'CRow is Current Row in SHeet 1
    'QnxtRow is writing row in Sheet 2
    'LastRow is Last Row
        Dim QCRow As Long
        Dim QLastRow As Long
        Dim QnxtRow As Long
        Dim ShiftCnt As Integer
    'Set Last Row by Counting Rows
    QLastRow = 13 'Cells(Rows.Count, "A").End(xlUp).Row
    QCRow = 2
    QnxtRow = 1

    'Label Columns
    Sheets(2).Cells(1, 5).Value = "Total Hours"
    Sheets(2).Cells(1, 6).Value = "A"
    Sheets(2).Cells(1, 7).Value = "B"
    Sheets(2).Cells(1, 8).Value = "C"
    Sheets(2).Cells(1, 9).Value = "D"
    Sheets(2).Cells(1, 10).Value = "E"
    Sheets(2).Cells(1, 11).Value = "F"


    'If New Day col1 OR New Person col10 Then copy row.
    'Else Same Person or Same Day, process other shifts

    Do Until QCRow = QLastRow
        QCol = 5
        TaskCnt = 0 'Reset TaskCnt for each new QnxtRow
        If Sheets(1).Cells(QCRow, 1) <> Sheets(1).Cells(QCRow - 1, 1) Or Sheets(1).Cells(QCRow, 2) <> Sheets(1).Cells(QCRow - 1, 2) Then
            Sheets(1).Select 'If new Date or new Person, copy Entry into a new row.
            Rows(QCRow).Copy
            QnxtRow = QnxtRow + 1   'QnxtRow is the Row that we are writing into on Sheet 2
            Sheets(2).Select
            Cells(QnxtRow, 1).Select
            ActiveSheet.Paste

            Sheets(2).Cells(QnxtRow, 5).Value = Sheets(1).Cells(QCRow, 4).Value 'Transpose Hours from Task#1
            Dim Stringer2 As String  'Now Categorize the Task from the first row as Task A, B, C... F.
            Stringer2 = Sheets(1).Cells(QCRow, 3).Value
            If InStr(1, Stringer2, "A") <> 0 Then Sheets(2).Cells(QnxtRow, 6).Value = 1
            If InStr(1, Stringer2, "B") <> 0 Then Sheets(2).Cells(QnxtRow, 7).Value = 1
            If InStr(1, Stringer2, "C") <> 0 Then Sheets(2).Cells(QnxtRow, 8).Value = 1
            If InStr(1, Stringer2, "D") <> 0 Then Sheets(2).Cells(QnxtRow, 9).Value = 1
            If InStr(1, Stringer2, "E") <> 0 Then Sheets(2).Cells(QnxtRow, 10).Value = 1
            If InStr(1, Stringer2, "F") <> 0 Then Sheets(2).Cells(QnxtRow, 11).Value = 1
            QCRow = QCRow + 1 'Index QCRow counter for shift 1
        Else 'If the Entry has the same new Date AND Employee, then just add the hours to the total hours and add categorize the Task as A, B, ...F
            Dim Stringer3 As String
            Stringer3 = Sheets(1).Cells(QCRow, 3).Value
            Sheets(2).Cells(QnxtRow, 5).Value = Sheets(2).Cells(QnxtRow, 5).Value + Sheets(1).Cells(QCRow, 4).Value 'Sum Hours
            If InStr(1, Stringer3, "A") <> 0 Then Sheets(2).Cells(QnxtRow, 6).Value = 1
            If InStr(1, Stringer3, "B") <> 0 Then Sheets(2).Cells(QnxtRow, 7).Value = 1
            If InStr(1, Stringer3, "C") <> 0 Then Sheets(2).Cells(QnxtRow, 8).Value = 1
            If InStr(1, Stringer3, "D") <> 0 Then Sheets(2).Cells(QnxtRow, 9).Value = 1
            If InStr(1, Stringer3, "E") <> 0 Then Sheets(2).Cells(QnxtRow, 10).Value = 1
            If InStr(1, Stringer3, "F") <> 0 Then Sheets(2).Cells(QnxtRow, 11).Value = 1
            QCRow = QCRow + 1 'Index QCRow counter
        End If
    Loop
End Sub

1. How many times do you have `Sheets(2)` in your code? Use `With` statement. 2. Avoid `Select` at all cost - https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba 3. `For` loops are faster than `Do` loops. 4. Don't declare anything as `Integer`, use `Long` instead. — Ryszard Jędraszyk, May 28 '18 at 22:30

dcromley · Answer 1 · 2018-05-29T01:51:54.927

I would recommend using "option explicit". You have to "Dim" all variables. It saves time in the long run. Variables Dimmed before any Subs or Functions are "global" which means they can be used everywhere.

Your 2 sets of "If Instr.." instructions are the same, so make a subroutine called "getTaskColumn" (below).

If you DO know your tasks beforehand, you can make a table:

  Dim nTasks&
  Dim aTaskNames$()
Sub makeTaskTable()
  nTasks = 2
  Redim aTaskNames(nTasks)
  aTaskNames(1) = "wash"
  aTaskNames(2) = "dry"
End Sub

If you DON'T know your tasks beforehand, make a pass to make a table:

For all your rows  
  taskName = cells(..)
  taskNumber = getTaskNumber(taskName) ' see below
  if taskNumber > nTasks then ' if not found
    nTasks = nTasks + 1  ' expand table
    Redim Preserve aTaskNames(nTasks)
    aTaskNames(nTasks) = taskName ' add entry
  End If
Next row

Now that you have a taskTable, you can lookup the taskNumber:

  taskName = cells(..)
  taskNumber = getTaskNumber(taskName) ' see below

And your taskColumn = 4 + taskNumber.

The getTaskNumber function:

Function getTaskNumber&(taskName$)
  dim i1&
  For i1 = 1 to nTasks
    if aTaskNames(i1) = taskName Then Exit For
  Next i1 ' i1 will be nTasks +1 if not found
  getTaskNumber = i1
End Function

Using a sorted table and a binary search would have better performance.

Tally data in Rows into Columns based on values - NOT simply transposing

1 Answers1