Iterating through row range group data and take an action - vba

Question

I am getting to know Excel VBA. I have a working program that uses an action button on one sheet opens a source workbook and data worksheet, selects data and puts that into a second workbook and destination sheet. I then sort the data as needed and it looks like this
Destination sheet, sorted and annotated duplicates
I am now trying to select the data based on col 2 "B" where the items are duplicated and/or not duplicated then perform an action (send an email to the manager about the staff under their control). I can get an email to work but its selecting the data that I'm having trouble with.
the output data would be col 1 & col 3 to 5 e.g.
Dear Manager1,
you staff member/s listed below have achieved xyz
Person1 22/06/2017 11/08/2017 22/08/2017
Person11 22/06/2017 11/08/2017 22/08/2017
Person15 22/06/2017 11/08/2017 22/08/2017
congratulations....
So what I hope somebody can help me with is a clue how I get to look at the data in col 2
add the Row data required to an array or something then to check the next Row add it to the same something until it is different to the next Row Pause do the action then do the next iteration. Resulting in:
Manager1 .....Person 1,11,15action
Manager10 ..... Person 10action
Manager2 ..... Person 12,16,2,25,28action
Manager3 ..... Person 13,17,26,29,3action
until last line is reached.
I am so confused with arrays / lookups and loops I have lost the plot somewhere along the way.
I have a variable lastTmp which tells me the last line of data in the set, this will vary each month.
The Range is:
Set rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).row)
The last piece of my working code is:
Dim lp As Integer
lp = 1
For Each cell In rng1
If 1 < Application.CountIf(rng1, cell.Value) Then
With cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next cell

Answer 1

You will be better placed to confront confusion if you do your indenting more logically. Related For / Next, If / Else / End If and With / End With should always be on the same indent level for easier reading. I rearranged your original code like this:-
For Each Cell In Rng1
If 1 < Application.CountIf(Rng1, Cell.Value) Then
With Cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With Cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next Cell
It now becomes apparent that the With Cell / End With need not be duplicated. I have further presumed that your variable lp actually was intended to hold the count. That made me arrive at the following compression of your code.
Dim Rng1 As Range
Dim Cell As Range
Dim lp As Integer
' the sheet isn't specified: uses the ActiveSheet
Set Rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each Cell In Rng1
With Cell
lp = Application.CountIf(Rng1, .Value)
.Offset(0, 4) = IIf(lp, "", "NOT ") & "duplicate : "
.Offset(0, 5) = lp
End With
Next Cell

Answer 2

Consider using a Dictionary or Collection, whenever, checking for duplicates.
Here I use a Dictionary of Dictionaries to compile lists of Persons by Manager.
Sub ListManagerList1()
Dim cell As Range
Dim manager As String, person As String
Dim key As Variant
Dim dictManagers As Object
Set dictManagers = CreateObject("Scripting.Dictionary")
For Each cell In Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
manager = cell.Value
person = cell.Offset(0, -1).Value
If Not dictManagers.Exists(manager) Then
dictManagers.Add manager, CreateObject("Scripting.Dictionary")
End If
If Not dictManagers(manager).Exists(person) Then
dictManagers(manager).Add person, vbNullString
End If
Next
For Each key In dictManagers
Debug.Print key & " -> "; Join(dictManagers(key).Keys(), ",")
Next
End Sub
I recommend you wanting Excel VBA Introduction Part 39 - Dictionaries

Answer 3

Assuming your data is as in the image
Then following code will give you result as in the image below.
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim lastRow As Long, i As Long
Dim arr1(), arr2()
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Set srcSht = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
Set destSht = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your output sheet
arr1 = Application.Index(srcSht.Cells, [row(1:7000)], Array(2, 1)) 'See note below
arr2 = arr1
For i = 1 To UBound(arr1, 1)
If Not dict.exists(LCase$(arr1(i, 1))) Then
dict.Add LCase$(arr1(i, 1)), i
Else
arr2(i, 1) = vbNullString
arr2(dict.Item(LCase$(arr1(i, 1))), 2) = arr2(dict.Item(LCase$(arr1(i, 1))), 2) & "," & arr1(i, 2)
End If
Next
destSht.Range("A1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr2 'display result
destSht.Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
End Sub
Note : For details on assigning range to array see this.