Summarizing Data

Hi,
I have a sample excel data which has 5 columns. I want to summarize them based on IDs and Work Time. So, for each ID, I need to sum its corresponding Work Time values and at the same time, keep other corresponding data too. For better understandings, I provided my desired final solution in sheet 2 (the answer should be written in a new sheet).
I think that I need to use VBA Dictionary.
Please help me out (Please note that I just need VBA code, not Power Pivot).

I wrote a code but I couldn't continue. I failed to complete the code. I'm new to VBA Dictionaries and don't have enough understandings of dictionary usage in different situation yet.

Sub test()
    Dim a, i As Long, txt As String, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("Sheet1").Range("A1:E11")
    For i = 1 To UBound(a, 1)
        txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), "~")
        dic(txt) = dic(txt) + a(i, 4)
    Next
    With Sheets.Add.Cells(1).Resize(, UBound(a, 2))
        .Value = Array("ID", "Farm", "Department", "Work Time", "Date")

Originally Posted by vba_php

can you post what you've already tried? the code to do this is very simple, but i would be interested to see what you've tried first. and by the way, SUMIF() will work for millions of lines of data. the count of rows is irrelevant. I just thought you could use it to your advantage.

I need to use VBA dictionar.

Sub test()
    Dim a, i As Long, txt As String, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    a = Sheets("Sheet1").Range("A1:E11")
    For i = 1 To UBound(a, 1)
        txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
        dic(txt) = dic(txt) + a(i, 4)
    Next
    With Sheets.Add.Cells(1).Resize(, UBound(a, 2))
        .Value = Array("ID", "Farm", "Department", "Work Time", "Date")

I learned this type of code in a tutorial but the tutorial aim was something else. I tried to solve my problem by that dictionary method but I failed. I'm sure VBA dictionary can do it.

Although it looks like you might have solved this, here is another code that may help. It's not pretty, but it worked for me on your data. I compared this outcome with that of Post#6 and found you must identify the whole range in that code, but this code can dynamically size to the data automatically.

Option Explicit

Sub filterrearrange()


Application.ScreenUpdating = False
Dim x, y As Range
Dim rng, rg As Range
Dim last, lr, i, j As Long
Dim sht, sp As String
Dim sum As Double

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:E" & last)

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "New"
Sheets("sheet1").Range("A1:E1").Copy Sheets("New").Range("A1")

Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("New").Range("A1"), Unique:=True

sum = 0
    j = 2
    For Each x In Sheets("New").Range([A2], Cells(Rows.Count, "A").End(xlUp))
        With rng
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=x.Value
            .SpecialCells(xlCellTypeVisible).Copy
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = x.Value
            ActiveSheet.Paste
            lr = Cells(Rows.Count, "D").End(xlUp).Row
            For i = 2 To lr
                sum = sum + Range("d" & i)
                Range("d2") = sum
            Next i
            sum = 0
        End With
    Next x
    
With ThisWorkbook.Sheets("New")
    .Select
     Range("A1").Select
End With

    'With Sheets("New")
    For Each y In Sheets("New").Range([A2], Cells(Rows.Count, "A").End(xlUp))
             Sheets("New").Range("B" & j).Value = Sheets(y.Text).Range("B2").Value
             Sheets("New").Range("C" & j).Value = Sheets(y.Text).Range("C2").Value
             Sheets("New").Range("D" & j).Value = Sheets(y.Text).Range("D2").Value
             Sheets("New").Range("E" & j).Value = Sheets(y.Text).Range("E2").Value
        j = j + 1
        Application.DisplayAlerts = False
        Sheets(y.Text).Delete
        Application.DisplayAlerts = True
    Next y
    'End With
    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    
    Application.ScreenUpdating = True
End Sub

Originally Posted by jindon

Did you?
https://www.excelforum.com/excel-pro...-a-report.html

I asked similar question before, but I made some changes to correspond this new problem. Actually, you helped me

Your result of 103 should be 5 not 3.9...

Sub sintek()
Dim Data, Dict As Object, Id As String, i As Long
Set Dict = CreateObject("Scripting.Dictionary")
Data = Sheet1.Cells(1).CurrentRegion
For i = 2 To UBound(Data)
    Id = Data(i, 1)
    If Not Dict.Exists(Id) Then
        Dict(Id) = Array(Id, Data(i, 2), Data(i, 3), Data(i, 4), Data(i, 5))
    Else
        Dict(Id) = Array(Dict(Id)(0), Dict(Id)(1), Dict(Id)(2), Dict(Id)(3) + Data(i, 4), Dict(Id)(4))
    End If
Next i
With Sheets.Add
    .Range("A1").Resize(, 5) = Sheet1.Range("A1").Resize(, 5).Value
    .Range("A2").Resize(Dict.Count, 5) = Application.Transpose(Application.Transpose(Dict.items))
    .UsedRange.Borders.LineStyle = xlContinuous
End With
End Sub