How to count number of occurrences of a value and the value of adjacent cell in a range

Question

Edit: This question has been re-worked to provide better clarity of my problem.

There's 2 factors to my question.

First Factor: I have a validation list in a sheet called "Admin Sheet". In that list are 'Tasks'. I would like to cross reference those tasks in the "list", against those contained in a range (rangeString) taken from another sheet and count the number of 'Occurrences' for each item.

i.e. Task 1 appears 3 times, Task 2 appears 1 time, etc etc..

Factor 2: For each item within the list I would also like to gather the number of 'Hours' spent on that task.

For example: Task 1 may appear 3 times on 3 different rows within the range. On each row in another column are the hours spent on that particular task. I would like to 'Sum' those hours from the 3 rows and I'd like to do this for all the 'Tasks'.

Note: The range is variable and will change daily. Note: The columns that contain the info are: 'F' - Tasks and 'K' for Hours.

My current attempt at just capturing 'one' Task and its Hours associated with it:

 Dim PaintWWArray() As Variant
 Dim PHoursCnt As Long

Set srchRng = ActiveSheet.Range(rangeString)
Set rngfindValue = srchRng.find(what:="AD PAINTING W/W", Lookat:=xlPart)

'Find all the Tasks and Hours
If Not rngfindValue Is Nothing Then
   rngFirstAddress = rngfindValue.Address
    Do
        PaintWWCnt = PaintWWCnt + 1
        PHoursCnt = rngfindValue.Offset(0, 4).Value

         ReDim Preserve PaintWWArray(PHoursCnt)
         PaintWWArray(PHoursCnt) = PHoursCnt

         Set rngfindValue = srchRng.FindNext(rngfindValue)


    Loop Until rngfindValue Is Nothing Or rngfindValue.Address = rngFirstAddress

     PWWSum = Application.WorksheetFunction.Sum(PaintWWArray)
     MsgBox PWWSum

End If    

Once I have collected the number of 'Occurrences' for each Task and the Sum of the hours for each task, I want to pass them into another sheet.

 Worksheets("Weekly Data").Range("C6").Value = PaintWWCnt
 Worksheets("Weekly Data").Range("D6").Value = PWWSum

I hope this is clearer...

Answer 1

I would suggest using a Dictionary.

Assuming you want to count all words:

Dim myDict
Set myDict = CreateObject("Scripting.Dictionary")
' Go through the array
For Each addDuty In arr
    ' If you only want to count specific words, add in IF statement here
    myDict(addDuty) = myDict(addDuty) + 1
Next addDuty 

If you only want to count words in an exiting set, it becomes slightly more elaborate.

Answer 2

It's not entirely clear what you want to achieve but the code below should give you the data you need. It's very fast. Please try it.

Private Sub STO_Answer()
    ' 024
    ' this procedure requires a reference to be set to
    ' Microsoft Scripting Runtime

    Dim Counter         As Scripting.Dictionary     ' store task names and their count
    Dim Arr             As Variant                  ' an array of the data in Rng
    Dim CellVal         As Variant                  ' temporary storage of each cell value
    Dim R               As Long                     ' row counter
    Dim Key             As Variant                  ' a dictionary Key

    Arr = ActiveSheet.Range("C2:D27").Value         ' change to name the sheet
                                                    ' adjust the range to suit
    Set Counter = New Scripting.Dictionary
    With Counter
        For R = 1 To UBound(Arr)                    ' loop through all rows
            AddToCounter Arr(R, 1), Counter         ' first column of cell range
            AddToCounter Arr(R, 2), Counter         ' second column of cell range
        Next R

        For Each Key In Counter.Keys
            Debug.Print Key, Counter.Item(Key)
        Next Key
    End With
End Sub

Private Sub AddToCounter(CellVal As Variant, _
                         Counter As Scripting.Dictionary)
    ' 024

    With Counter
        If .Exists(CellVal) Then
            .Item(CellVal) = .Item(CellVal) + 1
        Else
            .Add CellVal, 1
        End If
    End With
End Sub

A Dictionary is a data structure which holds two related values. Here it's used to hold the task name and the number of times it occurs. Make sure you enable the reference to Microsoft Scripting Runtime in Tools > References. You don't specify if there is any relationship- between the tasks in the first column and the second. The above code counts both independently for now.

The result is printed to the Immediate Window. Of course, you might use this result in any other way in your code. Your question doesn't cover your intentions.

Answer 3

You won't be able to escape from the necessity to present your count in some way forever. As it turns out, there is only one efficient way to do it. This one:-

All duties are in column A and all added duties are in row 2.

Of course, you might use rather elaborate VBA to do the counting but Excel has a better way using a worksheet function. In order to set up COUNTIF() to work I created two named ranges as follows.

["Duties"] =OFFSET(Sheet2!$C$2,0,0,COUNTA(Sheet2!$C:$C)-1)
and
["AddDuties"] =OFFSET(Duties,0,1)

Sheet2!$C$2 is where my data started. Replace with the first cell of the first column of your data range. COUNTA(Sheet2!$C:$C)-1 makes this range dynamic. The function counts how many entries there are in that same column, -1 because the count would include a caption (modify if you have more or fewer headers).

AddDuties is simply defined as "same as Duties" but removed by one column to the right. You could move it elsewhere. As you add or delete rows in the column of Duties, AddDuties expands or contracts right along.

Now the formula in B3 is shown below. It's copied down and across as required. Please observe the $ signs.

[B3] =COUNTIFS(Duties,$A3,AddDuties,B$2)

This will probably generate a lot of zeroes. It did in my example and I didn't like them. Therefore I formatted B3 with the Custom cell format 0;; before copying to the other cells, which hides them.

Now this list would automatically update as you make entries in your data. You will never have to run code and the list will always be ready.

Finally, one recommendation. All your added duties, like "AD PAINITNG H/R", are hard to type correctly. Therefore the user should select them from a validation drop-down when entering them in the data. Most probably, you already have a list somewhere which feeds such drop-downs. The captions in the count list must be taken from the same source. But that creates redundancy. The better way is to make the list in B2:H2 of the count list the "original". Name the range and make it dynamic and you will never have to think about this subject again.

Answer 4

i think a better approach would be to use for each loops, this way you won't have to hardcode the conditions via IfElse. If you have the values in column A of a sheet and wants to go through those values and get their adjacent value in column B, you can use For Each looping to go through each values defined in A to get B.

just to add, regarding on counting of occurrence, you can define a counter that would add up for each occurrence of a unique value in column A.

Answer 5

I do not have time to wait for clarifications I asked... I prepared a piece of code, starting from the assumption that your strings to be counted are in column "F:F", and the value to be calculated is in column "K:K". The processing result is dropped on the last available column of the active pages, starting from row 2. If you prefer some relevant headers for the two involved columns, this can be easily automated. I used "Tasks and "Time...

It is able to deal with as many 'task' strings you will have in the future.

I commented the code lines, where I thought you do not understand what they do:

Sub CountOccurrencesAndValues()
  Dim sh As Worksheet, rngF As Range, arrOcc As Variant, lastRow As Long, lastCol As Long
  Dim arr As Variant, arrFin As Variant, countI As Long, valH As Double, j As Long, k As Long, i As Long

  Set sh = ActiveSheet
  lastRow = sh.Range("F" & Rows.count).End(xlUp).Row
  lastCol = sh.UsedRange.Columns.count + 1
  Set rngF = sh.Range("F2:F" & lastRow) 'the range where from to extract the unique values
  arr = sh.Range("F2:K" & lastRow)      'the array to be processed

  'Extract the unique values. Use for that a not used column:
  rngF.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sh.Cells(1, lastCol), Unique:=True
  'Put the unique values (sttrings) in an array:
  arrOcc = sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).value
  'Clear the temporary used array:
  sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).Clear
  ReDim arrFin(1 To UBound(arrOcc, 1), 1 To 3)

  k = 1
  'Processing the range by iteration:
  For i = 1 To UBound(arrOcc, 1)
    For j = 1 To UBound(arr, 1)
      If arr(j, 1) = arrOcc(i, 1) Then
         'count the occurrences and the value
         countI = countI + 1: valH = valH + arr(j, 6)
      End If
    Next j
    'put the data in the final array
    arrFin(k, 1) = arrOcc(i, 1): arrFin(k, 2) = countI: arrFin(k, 3) = valH
    countI = 0: valH = 0: k = k + 1
  Next i

  'Drop the data from array in the last available column:
  'sh.Cells(1, lastCol).value = "Tasks": sh.Cells(1, lastCol + 1).value = "Count": sh.Cells(1, lastCol + 2).value = "Time"
  'sh.Cells(2, lastCol).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin

  Dim ws As Worksheet
  Set ws = Worksheets("Weekly Data")
  'Drop the data from array in "Weekly Data" worksheet:
  ws.Range("C6").value = "Tasks": ws.Range("D6").value = "Count": ws.Range("E6").value = "Time"
  ws.Range("C7").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub