List unique entries and total cells based on the results

[Thebatfink]

Hi,

Basically from Sheet OEE V20:V500 I have a list of problems being selected from a drop down list validation (which users can add to the list for new problems). Along side these "problems" in Sheet OEE U20:U500 I have a number which represents the number of minutes the problem caused them. Some cells in both these columns will however be empty if there was no problem occour. But wherever there is a problem selected, there will be a number alongside it, there will never be one without the other.

What I want to do is look down Sheet OEE V20:V500 and get two lots of information -

The unique problem names (no duplicates of the same problem) in Sheet Reports A1:A100 for example (I may change the range of this).
The number of occurances of each of the problems it lists in Sheets Reports B1:B100.
Count up the total number of minutes of each problem. So for every occurance of "Paper problem" there will be a unique number in Column U in the same row as the problem and place this in Sheet Reports C1:C100.

I would ideally like to have this as VB code as I am going to tie it into a command button which formats and prints my report page.

I have found various bits of code dotted about the forums for counting unique cell entries but they always seem to produce a list with lots of blank rows (I would like a list one after another without blank rows all over the place) and I'm really struggling to figure out how to make it count up the numbers in the adjacent cell of each entry it sees.

Just in case the list of problems for the cell validation in Sheet OEE V20:V500 is found in Sheet OEE AQ16 downwards.

If anyone could take alook at this and suggest anything it would be greatly appreciated.
Thanks!
Batfink

 

[Thebatfink]

Ended up with this.. Its probably turn the stomach of seasoned programmers but it seems to perform the task in hand!

Private Sub CommandButton3_Click()
Dim a, i As Long, b(), n As Long
With Sheets("OEE")
    a = .Range("v20", .Range("v" & Rows.Count).End(xlUp)).Offset(, -1).Resize(, 2).Value
End With
ReDim b(1 To UBound(a, 1), 1 To 4)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
       If Not IsEmpty(a(i, 2)) Then
        If Not .exists(a(i, 2)) Then
             n = n + 1: b(n, 1) = a(i, 2): .Add a(i, 2), n
       End If
            b(.Item(a(i, 2)), 2) = b(.Item(a(i, 2)), 2) + 1
            If a(i, 1) <> "" Then
               b(.Item(a(i, 2)), 3) = b(.Item(a(i, 2)), 3) + 1
                b(.Item(a(i, 2)), 4) = b(.Item(a(i, 2)), 4) + a(i, 1)
            End If
        End If
    Next
End With
Worksheets("Reports").Range("o4:v505").ClearContents
With Sheets("Reports").Range("o4")
    .Cells.Font.Name = "Arial"
    .Resize(, 4).Value = [{"problem","Total occurence","occurence with min","Total min"}]
    .Offset(1).Resize(n, 4).Value = b
End With
   Worksheets("Reports").Range("o5:r505").Sort _
        Key1:=Worksheets("Reports").Columns("r"), _
        Header:=xlGuess
Dim c, j As Long, d(), k As Long
With Sheets("OEE")
    c = .Range("p20", .Range("p" & Rows.Count).End(xlUp)).Offset(, -1).Resize(, 2).Value
End With
ReDim d(1 To UBound(c, 1), 1 To 4)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For j = 1 To UBound(c, 1)
       If Not IsEmpty(c(j, 2)) Then
        If Not .exists(c(j, 2)) Then
             k = k + 1: d(k, 1) = c(j, 2): .Add c(j, 2), k
       End If
            d(.Item(c(j, 2)), 2) = d(.Item(c(j, 2)), 2) + 1
            If c(j, 1) <> "" Then
               d(.Item(c(j, 2)), 3) = d(.Item(c(j, 2)), 3) + 1
                d(.Item(c(j, 2)), 4) = d(.Item(c(j, 2)), 4) + c(j, 1)
            End If
        End If
    Next
End With
With Sheets("Reports").Range("s4")
    .Cells.Font.Name = "Arial"
    .Resize(, 4).Value = [{"problem","Total occurence","occurence with min","Total min"}]
    .Offset(1).Resize(k, 4).Value = d
End With
   Worksheets("Reports").Range("s5:v505").Sort _
        Key1:=Worksheets("Reports").Columns("v"), _
        Header:=xlGuess
End Sub